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 name :: Text
name (SimpleSynonym value :: Text
value t :: Text
t) = Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$
      "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
forall a. Semigroup a => a -> a -> a
<> Text
value Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t
writePattern name :: Text
name (ExplicitSynonym view :: Text
view expression :: Text
expression value :: Text
value t :: Text
t) = do
  -- Supported only on ghc >= 7.10
  BaseVersion -> CodeGen ()
setModuleMinBase BaseVersion
Base48
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "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
forall a. Semigroup a => a -> a -> a
<> Text
view Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " -> "
           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
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " 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 -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
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
forall a. Semigroup a => a -> a -> a
<> Text
expression Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " 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
forall a. Semigroup a => a -> a -> a
<> Text
t

genConstant :: Name -> Constant -> CodeGen ()
genConstant :: Name -> Constant -> CodeGen ()
genConstant (Name _ name :: Text
name) c :: 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 ["PatternSynonyms", "ScopedTypeVariables", "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 (\e :: CGError
e -> Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "-- XXX: Could not generate constant: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CGError -> Text
describeCGError 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 ("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 name :: Text
name t :: Type
t@(TBasicType TPtr) value :: 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 "ptrToIntPtr" "intPtrToPtr" Text
value Text
ht)
assignValue name :: Text
name t :: Type
t@(TBasicType b :: BasicType
b) value :: 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 name :: Text
name t :: Type
t@(TInterface _) value :: 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 <- Type -> CodeGen (Maybe API)
findAPI Type
t
  case Maybe API
api of
    Just (APIEnum _) ->
        Text -> PatternSynonym -> CodeGen ()
writePattern Text
name (Text -> Text -> Text -> Text -> PatternSynonym
ExplicitSynonym "fromEnum" "toEnum" Text
value Text
ht)
    Just (APIFlags _) -> 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
forall a. Semigroup a => a -> a -> a
<> Text
value Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: Word64)"
        Text -> PatternSynonym -> CodeGen ()
writePattern Text
name (Text -> Text -> Text -> Text -> PatternSynonym
ExplicitSynonym "gflagsToWord" "wordToGFlags" Text
wordValue Text
ht)
    _ -> Text -> ExcCodeGen ()
forall a. Text -> ExcCodeGen a
notImplementedError (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "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 _ t :: Type
t _ = Text -> ExcCodeGen ()
forall a. Text -> ExcCodeGen a
notImplementedError (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "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 TInt     i :: Text
i       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType TUInt    i :: Text
i       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType TLong    i :: Text
i       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType TULong   i :: Text
i       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType TInt8    i :: Text
i       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType TUInt8   i :: Text
i       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType TInt16   i :: Text
i       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType TUInt16  i :: Text
i       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType TInt32   i :: Text
i       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType TUInt32  i :: Text
i       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType TInt64   i :: Text
i       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType TUInt64  i :: Text
i       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
showBasicType TBoolean "0"     = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "P.False"
showBasicType TBoolean "false" = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "P.False"
showBasicType TBoolean "1"     = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "P.True"
showBasicType TBoolean "true"  = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "P.True"
showBasicType TBoolean b :: 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
$ "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
<> "\""
showBasicType TFloat   f :: Text
f       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
f
showBasicType TDouble  d :: Text
d       = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
d
showBasicType TUTF8    s :: 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 TFileName fn :: 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 TUniChar c :: 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
forall a. Semigroup a => a -> a -> a
<> Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "'"
showBasicType TGType   gtype :: 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
$ "GType " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
gtype
showBasicType TIntPtr  ptr :: Text
ptr     = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
ptr
showBasicType TUIntPtr ptr :: 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 TPtr    _        = 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
$ "Cannot directly show a pointer"