module Data.GI.CodeGen.Constant
    ( genConstant
    ) where

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

import Data.GI.CodeGen.API
import Data.GI.CodeGen.Code
import Data.GI.CodeGen.Conversions
import Data.GI.CodeGen.Haddock (deprecatedPragma, writeDocumentation,
                                RelativeDocPosition(..))
import Data.GI.CodeGen.Type
import Data.GI.CodeGen.Util (tshow, ucFirst)

-- | Data for a bidrectional pattern synonym. It is either a simple
-- one of the form "pattern Name = value :: Type" or an explicit one
-- of the form
-- > pattern Name <- (view -> value) :: Type where
-- >    Name = expression value :: Type
data PatternSynonym = SimpleSynonym PSValue PSType
                    | ExplicitSynonym PSView PSExpression PSValue PSType

-- Some simple types for legibility
type PSValue = Text
type PSType = Text
type PSView = Text
type PSExpression = Text

writePattern :: Text -> PatternSynonym -> CodeGen ()
writePattern :: Text -> PatternSynonym -> CodeGen ()
writePattern Text
name (SimpleSynonym Text
value Text
t) = Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$
      Text
"pattern " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
value Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t
writePattern Text
name (ExplicitSynonym Text
view Text
expression Text
value Text
t) = do
  -- Supported only on ghc >= 7.10
  BaseVersion -> CodeGen ()
setModuleMinBase BaseVersion
Base48
  Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"pattern " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" <- (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
view Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> "
           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
value Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where"
  BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$
          Text -> Text
ucFirst Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
expression Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
value Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t

genConstant :: Name -> Constant -> CodeGen ()
genConstant :: Name -> Constant -> CodeGen ()
genConstant (Name Text
_ Text
name) Constant
c = 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
  [Text] -> CodeGen ()
setLanguagePragmas [Text
"PatternSynonyms", Text
"ScopedTypeVariables", Text
"ViewPatterns"]
  Text -> Maybe DeprecationInfo -> CodeGen ()
deprecatedPragma Text
name (Constant -> Maybe DeprecationInfo
constantDeprecated Constant
c)

  (CGError -> CodeGen ()) -> ExcCodeGen () -> CodeGen ()
forall a. (CGError -> CodeGen a) -> ExcCodeGen a -> CodeGen a
handleCGExc (\CGError
e -> do
                  Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"-- XXX: Could not generate constant"
                  CGError -> CodeGen ()
printCGError CGError
e
              )
    (do RelativeDocPosition -> Documentation -> CodeGen ()
writeDocumentation RelativeDocPosition
DocBeforeSymbol (Constant -> Documentation
constantDocumentation Constant
c)
        Text -> Type -> Text -> ExcCodeGen ()
assignValue Text
name (Constant -> Type
constantType Constant
c) (Constant -> Text
constantValue Constant
c)
        HaddockSection -> Text -> CodeGen ()
export HaddockSection
ToplevelSection (Text
"pattern " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
name))

-- | Assign to the given name the given constant value, in a way that
-- can be assigned to the corresponding Haskell type.
assignValue :: Text -> Type -> Text -> ExcCodeGen ()
assignValue :: Text -> Type -> Text -> ExcCodeGen ()
assignValue Text
name t :: Type
t@(TBasicType BasicType
TPtr) Text
value = do
  Text
ht <- TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
haskellType Type
t
  Text -> PatternSynonym -> CodeGen ()
writePattern Text
name (Text -> Text -> Text -> Text -> PatternSynonym
ExplicitSynonym Text
"ptrToIntPtr" Text
"intPtrToPtr" Text
value Text
ht)
assignValue Text
name t :: Type
t@(TBasicType BasicType
b) Text
value = do
  Text
ht <- TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
haskellType Type
t
  Text
hv <- BasicType
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
showBasicType BasicType
b Text
value
  Text -> PatternSynonym -> CodeGen ()
writePattern Text
name (Text -> Text -> PatternSynonym
SimpleSynonym Text
hv Text
ht)
assignValue Text
name t :: Type
t@(TInterface Name
_) Text
value = do
  Text
ht <- TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
haskellType Type
t
  Maybe API
api <- HasCallStack => Type -> CodeGen (Maybe API)
Type -> CodeGen (Maybe API)
findAPI Type
t
  case Maybe API
api of
    Just (APIEnum Enumeration
_) ->
        Text -> PatternSynonym -> CodeGen ()
writePattern Text
name (Text -> Text -> Text -> Text -> PatternSynonym
ExplicitSynonym Text
"fromEnum" Text
"toEnum" Text
value Text
ht)
    Just (APIFlags Flags
_) -> do
        -- gflagsToWord and wordToGFlags are polymorphic, so in this
        -- case we need to specialize so the type of the pattern is
        -- not ambiguous.
        let wordValue :: Text
wordValue = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
value Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" :: Word64)"
        Text -> PatternSynonym -> CodeGen ()
writePattern Text
name (Text -> Text -> Text -> Text -> PatternSynonym
ExplicitSynonym Text
"gflagsToWord" Text
"wordToGFlags" Text
wordValue Text
ht)
    Maybe API
_ -> Text -> ExcCodeGen ()
forall a. Text -> ExcCodeGen a
notImplementedError (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"Don't know how to treat constants of type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
forall a. Show a => a -> Text
tshow Type
t
assignValue Text
_ Type
t Text
_ = Text -> ExcCodeGen ()
forall a. Text -> ExcCodeGen a
notImplementedError (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"Don't know how to treat constants of type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
forall a. Show a => a -> Text
tshow Type
t

-- | Show a basic type, in a way that can be assigned to the
-- corresponding Haskell type.
showBasicType                  :: BasicType -> Text -> ExcCodeGen Text
showBasicType :: BasicType
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
showBasicType BasicType
TInt     Text
i       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TUInt    Text
i       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TLong    Text
i       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TULong   Text
i       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TInt8    Text
i       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TUInt8   Text
i       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TInt16   Text
i       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TUInt16  Text
i       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TInt32   Text
i       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TUInt32  Text
i       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TInt64   Text
i       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TUInt64  Text
i       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TBoolean Text
"0"     = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"P.False"
showBasicType BasicType
TBoolean Text
"false" = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"P.False"
showBasicType BasicType
TBoolean Text
"1"     = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"P.True"
showBasicType BasicType
TBoolean Text
"true"  = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"P.True"
showBasicType BasicType
TBoolean Text
b       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall a. Text -> ExcCodeGen a
notImplementedError (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text)
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall a b. (a -> b) -> a -> b
$ Text
"Could not parse boolean \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
showBasicType BasicType
TFloat   Text
f       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
f
showBasicType BasicType
TDouble  Text
d       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
d
showBasicType BasicType
TUTF8    Text
s       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text)
-> (Text -> Text)
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
forall a. Show a => a -> Text
tshow (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text)
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall a b. (a -> b) -> a -> b
$ Text
s
showBasicType BasicType
TFileName Text
fn     = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text)
-> (Text -> Text)
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
forall a. Show a => a -> Text
tshow (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text)
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall a b. (a -> b) -> a -> b
$ Text
fn
showBasicType BasicType
TUniChar Text
c       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text)
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall a b. (a -> b) -> a -> b
$ Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"
showBasicType BasicType
TGType   Text
gtype   = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text)
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall a b. (a -> b) -> a -> b
$ Text
"GType " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
gtype
showBasicType BasicType
TIntPtr  Text
ptr     = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
ptr
showBasicType BasicType
TUIntPtr Text
ptr     = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
ptr
-- We take care of this one separately above
showBasicType BasicType
TPtr    Text
_        = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall a. Text -> ExcCodeGen a
notImplementedError (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text)
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall a b. (a -> b) -> a -> b
$ Text
"Cannot directly show a pointer"