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 e ()
writePattern :: forall e. Text -> PatternSynonym -> CodeGen e ()
writePattern Text
name (SimpleSynonym Text
value Text
t) = forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$
      Text
"pattern " forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
name forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Text
value forall a. Semigroup a => a -> a -> a
<> 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
  forall e. BaseVersion -> CodeGen e ()
setModuleMinBase BaseVersion
Base48
  forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"pattern " forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
name forall a. Semigroup a => a -> a -> a
<> Text
" <- (" forall a. Semigroup a => a -> a -> a
<> Text
view forall a. Semigroup a => a -> a -> a
<> Text
" -> "
           forall a. Semigroup a => a -> a -> a
<> Text
value forall a. Semigroup a => a -> a -> a
<> Text
") :: " forall a. Semigroup a => a -> a -> a
<> Text
t forall a. Semigroup a => a -> a -> a
<> Text
" where"
  forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$
          Text -> Text
ucFirst Text
name forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Text
expression forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
value forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> Text
t

genConstant :: Name -> Constant -> CodeGen e ()
genConstant :: forall e. Name -> Constant -> CodeGen e ()
genConstant (Name Text
_ Text
name) Constant
c = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
  forall e. [Text] -> CodeGen e ()
setLanguagePragmas [Text
"PatternSynonyms", Text
"ScopedTypeVariables", Text
"ViewPatterns"]
  forall e. Text -> Maybe DeprecationInfo -> CodeGen e ()
deprecatedPragma Text
name (Constant -> Maybe DeprecationInfo
constantDeprecated Constant
c)

  forall e a. (CGError -> CodeGen e a) -> ExcCodeGen a -> CodeGen e a
handleCGExc (\CGError
e -> do
                  forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"-- XXX: Could not generate constant"
                  forall e. CGError -> CodeGen e ()
printCGError CGError
e
              )
    (do forall e. RelativeDocPosition -> Documentation -> CodeGen e ()
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)
        forall e. HaddockSection -> Text -> CodeGen e ()
export HaddockSection
ToplevelSection (Text
"pattern " 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
haskellType Type
t
  forall e. Text -> PatternSynonym -> CodeGen e ()
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
haskellType Type
t
  Text
hv <- BasicType
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
showBasicType BasicType
b Text
value
  forall e. Text -> PatternSynonym -> CodeGen e ()
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
haskellType Type
t
  Maybe API
api <- forall e. HasCallStack => Type -> CodeGen e (Maybe API)
findAPI Type
t
  case Maybe API
api of
    Just (APIEnum Enumeration
_) ->
        forall e. Text -> PatternSynonym -> CodeGen e ()
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
"(" forall a. Semigroup a => a -> a -> a
<> Text
value forall a. Semigroup a => a -> a -> a
<> Text
" :: Word64)"
        forall e. Text -> PatternSynonym -> CodeGen e ()
writePattern Text
name (Text -> Text -> Text -> Text -> PatternSynonym
ExplicitSynonym Text
"gflagsToWord" Text
"wordToGFlags" Text
wordValue Text
ht)
    Maybe API
_ -> forall a. Text -> ExcCodeGen a
notImplementedError forall a b. (a -> b) -> a -> b
$ Text
"Don't know how to treat constants of type " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Type
t
assignValue Text
_ Type
t Text
_ = forall a. Text -> ExcCodeGen a
notImplementedError forall a b. (a -> b) -> a -> b
$ Text
"Don't know how to treat constants of type " forall a. Semigroup a => a -> a -> a
<> 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       = forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TUInt    Text
i       = forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TLong    Text
i       = forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TULong   Text
i       = forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TInt8    Text
i       = forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TUInt8   Text
i       = forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TInt16   Text
i       = forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TUInt16  Text
i       = forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TInt32   Text
i       = forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TUInt32  Text
i       = forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TInt64   Text
i       = forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TUInt64  Text
i       = forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType BasicType
TBoolean Text
"0"     = forall (m :: * -> *) a. Monad m => a -> m a
return Text
"P.False"
showBasicType BasicType
TBoolean Text
"false" = forall (m :: * -> *) a. Monad m => a -> m a
return Text
"P.False"
showBasicType BasicType
TBoolean Text
"1"     = forall (m :: * -> *) a. Monad m => a -> m a
return Text
"P.True"
showBasicType BasicType
TBoolean Text
"true"  = forall (m :: * -> *) a. Monad m => a -> m a
return Text
"P.True"
showBasicType BasicType
TBoolean Text
b       = forall a. Text -> ExcCodeGen a
notImplementedError forall a b. (a -> b) -> a -> b
$ Text
"Could not parse boolean \"" forall a. Semigroup a => a -> a -> a
<> Text
b forall a. Semigroup a => a -> a -> a
<> Text
"\""
showBasicType BasicType
TFloat   Text
f       = forall (m :: * -> *) a. Monad m => a -> m a
return Text
f
showBasicType BasicType
TDouble  Text
d       = forall (m :: * -> *) a. Monad m => a -> m a
return Text
d
showBasicType BasicType
TUTF8    Text
s       = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> Text
tshow forall a b. (a -> b) -> a -> b
$ Text
s
showBasicType BasicType
TFileName Text
fn     = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> Text
tshow forall a b. (a -> b) -> a -> b
$ Text
fn
showBasicType BasicType
TUniChar Text
c       = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
"'" forall a. Semigroup a => a -> a -> a
<> Text
c forall a. Semigroup a => a -> a -> a
<> Text
"'"
showBasicType BasicType
TGType   Text
gtype   = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
"GType " forall a. Semigroup a => a -> a -> a
<> Text
gtype
showBasicType BasicType
TIntPtr  Text
ptr     = forall (m :: * -> *) a. Monad m => a -> m a
return Text
ptr
showBasicType BasicType
TUIntPtr Text
ptr     = forall (m :: * -> *) a. Monad m => a -> m a
return Text
ptr
-- We take care of this one separately above
showBasicType BasicType
TPtr    Text
_        = forall a. Text -> ExcCodeGen a
notImplementedError forall a b. (a -> b) -> a -> b
$ Text
"Cannot directly show a pointer"