-- | Convert Salt types to LLVM types.
module DDC.Core.Llvm.Convert.Type
        ( -- * Type conversion.
          convertType
        , convertSuperType
        , importedFunctionDeclOfType

          -- * Builtin Types
        , tObj, sObj,  aObj
        , tPtr, tAddr, tNat, tInt, tTag

          -- * Type Constructors
        , convTyCon

          -- * Predicates
        , isVoidT
        , isSignedT
        , isUnsignedT
        , isIntegralT
        , isFloatingT)
where
import DDC.Core.Llvm.Convert.Base
import DDC.Llvm.Syntax.Type
import DDC.Llvm.Syntax.Attr
import DDC.Core.Salt.Platform
import DDC.Type.Env
import DDC.Type.Compounds
import DDC.Type.Predicates
import DDC.Base.Pretty
import qualified DDC.Core.Salt          as A
import qualified DDC.Core.Salt.Name     as A
import qualified DDC.Core.Salt.Convert  as A
import qualified DDC.Core.Module        as C
import qualified DDC.Core.Exp           as C
import qualified DDC.Type.Env           as Env
import Control.Monad


-- Type -----------------------------------------------------------------------
-- | Convert a Salt type to an LlvmType.
convertType :: Platform -> KindEnv A.Name -> C.Type A.Name -> ConvertM Type
convertType pp kenv tt
 = case tt of
        -- A polymorphic type,
        -- represented as a generic boxed object.
        C.TVar u
         -> case Env.lookup u kenv of
             Nothing            
              -> throw $ ErrorInvalidBound u
                       $ Just "Type variable not in kind environment."

             Just k
              | isDataKind k    
              -> return $ TPointer (tObj pp)

              | otherwise       
              -> throw $ ErrorInvalidBound u
                       $ Just "Bound type variable does not have kind Data."

        -- A primitive type.
        C.TCon tc
          -> convTyCon pp tc

        -- A pointer to a primitive type.
        C.TApp{}
         | Just (A.NamePrimTyCon A.PrimTyConPtr, [_r, t2]) 
                <- takePrimTyConApps tt
         -> do  t2'     <- convertType pp kenv t2
                return  $ TPointer t2'

        -- Function types become pointers to functions.
        C.TApp{}
         -> do  (tsArgs, tResult)    <- convertSuperType pp kenv tt
                return  
                  $ TPointer $ TFunction 
                  $ FunctionDecl
                  { declName          = "dummy.function.name"
                  , declLinkage       = Internal
                  , declCallConv      = CC_Ccc
                  , declReturnType    = tResult
                  , declParamListType = FixedArgs
                  , declParams        = [Param t [] | t <- tsArgs]
                  , declAlign         = AlignBytes (platformAlignBytes pp) }
        
        C.TForall b t
         -> let kenv'   = Env.extend b kenv
            in  convertType pp kenv' t
          
        _ -> throw $ ErrorInvalidType tt
                   $ Just "Cannot convert type."


-- Super Type -----------------------------------------------------------------
-- | Split the parameter and result types from a supercombinator type and
--   and convert them to LLVM form. 
--
--   We can't split the type first and just call 'convertType' above as we need
--   to decend into any quantifiers that wrap the body type.
convertSuperType 
        :: Platform
        -> KindEnv A.Name
        -> C.Type  A.Name
        -> ConvertM ([Type], Type)

convertSuperType pp kenv tt
 = case tt of
        C.TApp{}
         |  (_, tsArgs, tResult) <- takeTFunWitArgResult tt
         ,  not $ null tsArgs
         -> do  tsArgs'   <- mapM (convertType pp kenv) tsArgs
                tResult'  <- convertType pp kenv tResult
                return (tsArgs', tResult')

        C.TForall b t
         -> let kenv' = Env.extend b kenv
            in  convertSuperType pp kenv' t

        _ -> throw $ ErrorInvalidType tt
                   $ Just $ "Cannot use this as the type of a super."
                          ++ show (takeTFunArgResult tt)


-- Imports --------------------------------------------------------------------
-- | Convert an imported function type to a LLVM declaration.
importedFunctionDeclOfType 
        :: Platform
        -> KindEnv A.Name
        -> C.ImportValue A.Name
        -> Maybe (C.ExportSource A.Name)
        -> A.Name
        -> C.Type A.Name 
        -> Maybe (ConvertM FunctionDecl)

importedFunctionDeclOfType pp kenv isrc mesrc nSuper tt
 
 | C.ImportValueModule{} <- isrc
 = Just $ do
        let Just strName 
                = liftM renderPlain 
                $ A.seaNameOfSuper (Just isrc) mesrc nSuper
        
        (tsArgs, tResult)       <- convertSuperType pp kenv tt
        let mkParam t           = Param t []
        return  $ FunctionDecl
                { declName           = A.sanitizeName strName
                , declLinkage        = External
                , declCallConv       = CC_Ccc
                , declReturnType     = tResult
                , declParamListType  = FixedArgs
                , declParams         = map mkParam tsArgs
                , declAlign          = AlignBytes (platformAlignBytes pp) }

 | C.ImportValueSea strName _  <- isrc
 = Just $ do
        (tsArgs, tResult)       <- convertSuperType pp kenv tt
        let mkParam t           = Param t []
        return  $ FunctionDecl
                { declName           = A.sanitizeName strName
                , declLinkage        = External
                , declCallConv       = CC_Ccc
                , declReturnType     = tResult
                , declParamListType  = FixedArgs
                , declParams         = map mkParam tsArgs
                , declAlign          = AlignBytes (platformAlignBytes pp) }

importedFunctionDeclOfType _ _ _ _ _ _
        = Nothing


-- TyCon ----------------------------------------------------------------------
-- | Convert a Sea TyCon to a LlvmType.
convTyCon :: Platform -> C.TyCon A.Name -> ConvertM Type
convTyCon platform tycon
 = case tycon of
        C.TyConSpec  C.TcConUnit
         -> return $ TPointer (tObj platform)

        C.TyConBound (C.UPrim A.NameObjTyCon _) _
         -> return $ tObj platform

        C.TyConBound (C.UPrim (A.NamePrimTyCon tc) _) _
         -> case tc of
             A.PrimTyConVoid      -> return $ TVoid
             A.PrimTyConBool      -> return $ TInt 1
             A.PrimTyConNat       -> return $ TInt (8 * platformAddrBytes platform)
             A.PrimTyConInt       -> return $ TInt (8 * platformAddrBytes platform)
             A.PrimTyConWord bits -> return $ TInt (fromIntegral bits)
             A.PrimTyConTag       -> return $ TInt (8 * platformTagBytes  platform)
             A.PrimTyConAddr      -> return $ TInt (8 * platformAddrBytes platform)

             A.PrimTyConFloat bits
              -> case bits of
                        32        -> return TFloat
                        64        -> return TDouble
                        80        -> return TFloat80
                        128       -> return TFloat128

                        _ -> throw $ ErrorInvalidTyCon tycon
                                   $ Just "Float has a non-standard width."

             -- Text literals are represented as pointers to the static text data.
             A.PrimTyConTextLit   -> return $ tPtr (TInt 8)

             _            -> throw $ ErrorInvalidTyCon tycon
                                   $ Just "Not a primitive type constructor."

        _ -> throw $ ErrorInvalidTyCon tycon
                   $ Just "Cannot convert type constructor."


-- | Type of Heap objects.
sObj, tObj :: Platform -> Type
sObj platform   = TStruct [TInt (8 * platformObjBytes platform)]
tObj platform   = TAlias (aObj platform)

aObj :: Platform -> TypeAlias
aObj platform   = TypeAlias "s.Obj" (sObj platform)


-- | Alias for pointer type.
tPtr :: Type -> Type
tPtr t = TPointer t


-- | Alias for address type.
tAddr :: Platform -> Type
tAddr pp = TInt (8 * platformAddrBytes pp)


-- | Alias for natural numner type.
tNat :: Platform -> Type
tNat pp = TInt (8 * platformAddrBytes pp)


-- | Alias for machine integer type.
tInt :: Platform -> Type
tInt pp = TInt (8 * platformAddrBytes pp)


-- | Alias for address type.
tTag :: Platform -> Type
tTag pp = TInt (8 * platformTagBytes  pp)


-- Predicates -----------------------------------------------------------------
-- | Check whether this is the Void# type.
isVoidT :: C.Type A.Name -> Bool
isVoidT (C.TCon (C.TyConBound (C.UPrim (A.NamePrimTyCon A.PrimTyConVoid) _) _)) 
         = True
isVoidT _ = False


-- | Check whether some type is signed: IntN or FloatN.
isSignedT :: C.Type A.Name -> Bool
isSignedT tt
 = case tt of
        C.TCon (C.TyConBound (C.UPrim (A.NamePrimTyCon tc) _) _)
          -> A.primTyConIsSigned tc
        _ -> False


-- | Check whether some type is unsigned: NatN or WordN
isUnsignedT :: C.Type A.Name -> Bool
isUnsignedT tt
 = case tt of
        C.TCon (C.TyConBound (C.UPrim (A.NamePrimTyCon tc) _) _)
          -> A.primTyConIsUnsigned tc
        _ -> False


-- | Check whether some type is an integral type. Nat, Int, WordN or Addr
isIntegralT :: C.Type A.Name -> Bool
isIntegralT tt
 = case tt of
        C.TCon (C.TyConBound (C.UPrim (A.NamePrimTyCon tc) _) _)
          -> A.primTyConIsIntegral tc
        _ -> False


-- | Check whether some type is an integral type. Nat, IntN or WordN.
isFloatingT :: C.Type A.Name -> Bool
isFloatingT tt
 = case tt of
        C.TCon (C.TyConBound (C.UPrim (A.NamePrimTyCon tc) _) _)
          -> A.primTyConIsFloating tc
        _ -> False