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

    , classConstraint
    , typeConstraint

    , hyphensToCamelCase
    , underscoresToCamelCase

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

    , signalHaskellName
    , signalInfoName

    , submoduleLocation
    , qualifiedAPI
    , qualifiedSymbol
    ) 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, group, line, exportDecl,
                             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 _ s :: Text
s) = Text -> Name -> CodeGen Text
qualifiedSymbol ("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 n :: Name
n) = Name -> CodeGen Text
classConstraint Name
n
typeConstraint t :: 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
$ "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 ("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
<> "_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 ("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 ("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 ("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 ("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 ("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 ("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 ('_', xs :: Text
xs)) = Text -> Text
sanitize Text
xs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "_"
sanitize xs :: 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 _ s :: 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 s :: Text
s = case Text -> Text
underscoresToCamelCase (Text -> Text
sanitize Text
s) of
                  "" -> [Char] -> Text
forall a. HasCallStack => [Char] -> a
error "empty name!!"
                  n :: 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 _ s :: 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 _ (APIConst _) = "Constants"
submoduleLocation _ (APIFunction _) = "Functions"
submoduleLocation _ (APICallback _) = "Callbacks"
submoduleLocation _ (APIEnum _) = "Enums"
submoduleLocation _ (APIFlags _) = "Flags"
submoduleLocation n :: Name
n (APIInterface _) = "Interfaces" ModulePath -> Text -> ModulePath
/. Name -> Text
upperName Name
n
submoduleLocation n :: Name
n (APIObject _) = "Objects" ModulePath -> Text -> ModulePath
/. Name -> Text
upperName Name
n
submoduleLocation n :: Name
n (APIStruct _) = "Structs" ModulePath -> Text -> ModulePath
/. Name -> Text
upperName Name
n
submoduleLocation n :: Name
n (APIUnion _) = "Unions" ModulePath -> Text -> ModulePath
/. Name -> Text
upperName Name
n

-- | Return an identifier for the given interface type valid in the current
-- module.
qualifiedAPI :: Name -> CodeGen Text
qualifiedAPI :: Name -> CodeGen Text
qualifiedAPI n :: Name
n@(Name ns :: Text
ns _) = do
  API
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) Name
n

-- | Construct an identifier for the given symbol in the given API.
qualifiedSymbol :: Text -> Name -> CodeGen Text
qualifiedSymbol :: Text -> Name -> CodeGen Text
qualifiedSymbol s :: Text
s n :: Name
n@(Name ns :: Text
ns _) = do
  API
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)

-- | Save a bit of typing for optional arguments in the case that we
-- want to pass Nothing.
noName :: Text -> CodeGen ()
noName :: Text -> CodeGen ()
noName name' :: Text
name' = BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
  -- We should use `writeHaddock` here, but it would give rise to a
  -- cyclic import.
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "-- | A convenience alias for `Nothing` :: `Maybe` `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "`."
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "no" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: Maybe " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name'
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "no" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = Nothing"
  Text -> CodeGen ()
exportDecl ("no" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name')

-- | 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
== '-')

-- | 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
== '_')
        where normalize :: Text -> Text
              normalize :: Text -> Text
normalize "" = "_"
              normalize s :: 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 -> 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 "type" = "type_"
escapeReserved "in" = "in_"
escapeReserved "data" = "data_"
escapeReserved "instance" = "instance_"
escapeReserved "where" = "where_"
escapeReserved "module" = "module_"
-- Reserved because we generate code that uses these names.
escapeReserved "result" = "result_"
escapeReserved "return" = "return_"
escapeReserved "show" = "show_"
escapeReserved "fromEnum" = "fromEnum_"
escapeReserved "toEnum" = "toEnum_"
escapeReserved "undefined" = "undefined_"
escapeReserved "error" = "error_"
escapeReserved "map" = "map_"
escapeReserved "length" = "length_"
escapeReserved "mapM" = "mapM__"
escapeReserved "mapM_" = "mapM___"
escapeReserved "fromIntegral" = "fromIntegral_"
escapeReserved "realToFrac" = "realToFrac_"
escapeReserved "peek" = "peek_"
escapeReserved "poke" = "poke_"
escapeReserved "sizeOf" = "sizeOf_"
escapeReserved "when" = "when_"
escapeReserved "default" = "default_"
escapeReserved s :: Text
s
    | "set_" Text -> Text -> Bool
`T.isPrefixOf` Text
s = Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "_"
    | "get_" Text -> Text -> Bool
`T.isPrefixOf` Text
s = Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "_"
    | 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 n :: Name
n signal :: 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
<> "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 sn :: Text
sn = let (w :: Text
w:ws :: [Text]
ws) = (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-') 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)