-----------------------------------------------------------------------------
-- |
-- Module      :  Language.C.Analysis.Export
-- Copyright   :  (c) 2008 Benedikt Huber
-- License     :  BSD-style
-- Maintainer  :  benedikt.huber@gmail.com
-- Stability   :  prototype
-- Portability :  ghc
--
-- /WARNING/ : This is just an implementation sketch and not very well tested.
--
-- Export 'SemRep' entities to 'AST' nodes.
-----------------------------------------------------------------------------
module Language.C.Analysis.Export (
exportDeclr,
exportType, exportTypeDecl, exportTypeSpec,
exportTypeDef,
exportCompType, exportCompTypeDecl, exportCompTypeRef,
exportEnumType, exportEnumTypeDecl, exportEnumTypeRef,
)
where
import Language.C.Data.Ident
import Language.C.Data.Name (nameId)
import Language.C.Data.Node
import Language.C.Syntax.AST
import Language.C.Analysis.SemRep
import Data.Maybe

-- |Export Declarator
--
--  Synopsis: @exportDeclr other_specs type attributes variable-name@
exportDeclr :: [CDeclSpec] -> Type -> Attributes -> VarName -> ([CDeclSpec],CDeclr)
exportDeclr other_specs ty attrs name =
    (other_specs ++ specs, CDeclr ident derived asmname (exportAttrs attrs) ni)
    where
    (specs,derived) = exportType ty
    (ident,asmname) = case name of (VarName vident asmname_opt) -> (Just vident, asmname_opt)
                                   _ -> (Nothing,Nothing)

exportTypeDecl :: Type -> CDecl
exportTypeDecl ty =
  CDecl declspecs declrs ni
  where
  (declspecs,derived) = exportType ty
  declrs | null derived = []
         | otherwise = [(Just $ CDeclr Nothing derived Nothing [] ni,Nothing,Nothing)]

exportTypeDef :: TypeDef -> CDecl
exportTypeDef (TypeDef ident ty attrs node_info) =
  CDecl (CStorageSpec (CTypedef ni) : declspecs) [declr] node_info
  where
  (declspecs,derived) = exportType ty
  declr = (Just $ CDeclr (Just ident) derived Nothing (exportAttrs attrs) ni, Nothing, Nothing)

-- |Export a type to syntax
exportType :: Type -> ([CDeclSpec],[CDerivedDeclr])
exportType ty = exportTy [] ty
  where
    exportTy dd (PtrType ity tyquals attrs) =
        let ptr_declr = CPtrDeclr (exportTypeQualsAttrs tyquals attrs) ni
        in  exportTy (ptr_declr : dd) ity
    exportTy dd (ArrayType ity array_sz tyquals attrs) =
        let arr_declr = CArrDeclr (exportTypeQualsAttrs tyquals attrs) (exportArraySize array_sz) ni
        in  exportTy (arr_declr : dd) ity
    exportTy dd (FunctionType (FunType ity params variadic) attrs) =
        let fun_declr = CFunDeclr (Right (map exportParamDecl params,variadic)) (exportAttrs attrs) ni
        in  exportTy (fun_declr : dd) ity
    exportTy dd (FunctionType (FunTypeIncomplete ity) attrs) =
        let fun_declr = CFunDeclr (Right ([],False)) (exportAttrs attrs) ni
        in  exportTy (fun_declr : dd) ity
    exportTy dd (TypeDefType (TypeDefRef ty_ident _ node) quals attrs) =
        let declspecs =    [CTypeSpec (CTypeDef ty_ident node)]
                        ++ map CTypeQual (exportTypeQualsAttrs quals attrs)
        in (declspecs, reverse dd)
    exportTy dd (DirectType ity quals attrs) =
        let declspecs =    map CTypeQual (exportTypeQualsAttrs quals attrs)
                        ++ map CTypeSpec (exportTypeSpec ity)
        in (declspecs, reverse dd)

exportTypeQuals :: TypeQuals -> [CTypeQual]
exportTypeQuals quals = mapMaybe select [(constant,CConstQual ni),(volatile,CVolatQual ni),(restrict,CRestrQual ni)]
    where
    select (predicate,tyqual) | predicate quals = Just tyqual
                              | otherwise       = Nothing

exportTypeQualsAttrs :: TypeQuals -> Attributes -> [CTypeQual]
exportTypeQualsAttrs tyqs attrs = (exportTypeQuals tyqs ++ map CAttrQual (exportAttrs attrs))

exportArraySize :: ArraySize -> CArrSize
exportArraySize (ArraySize static e) = CArrSize static e
exportArraySize (UnknownArraySize complete) = CNoArrSize complete

exportTypeSpec :: TypeName -> [CTypeSpec]
exportTypeSpec tyname =
    case tyname of
        TyVoid -> [CVoidType ni]
        TyIntegral ity -> exportIntType ity
        TyFloating fty -> exportFloatType fty
        TyComplex fty -> exportComplexType fty
        TyComp comp -> exportCompTypeDecl comp
        TyEnum enum -> exportEnumTypeDecl enum
        TyBuiltin TyVaList -> [CTypeDef (internalIdent "va_list") ni]
        TyBuiltin TyAny -> [CTypeDef (internalIdent "__ty_any") ni]

exportIntType :: IntType -> [CTypeSpec]
exportIntType ty =
    case ty of
      TyBool    -> [CBoolType ni]
      TyChar    -> [CCharType ni]
      TySChar   -> [CSignedType ni,CCharType ni]
      TyUChar   -> [CUnsigType ni,CCharType ni]
      TyShort   -> [CShortType ni]
      TyUShort  -> [CUnsigType ni, CShortType ni]
      TyInt     -> [CIntType ni]
      TyUInt    -> [CUnsigType ni, CIntType ni]
      TyLong    -> [CLongType ni]
      TyULong   -> [CUnsigType ni,CLongType ni]
      TyLLong   -> [CLongType ni, CLongType ni]
      TyULLong  -> [CUnsigType ni, CLongType ni, CLongType ni]

exportFloatType :: FloatType -> [CTypeSpec]
exportFloatType ty =
    case ty of
      TyFloat   -> [CFloatType ni]
      TyDouble  -> [CDoubleType ni]
      TyLDouble -> [CLongType ni, CDoubleType ni]

exportComplexType :: FloatType -> [CTypeSpec]
exportComplexType ty = (CComplexType ni) : exportFloatType ty

exportCompTypeDecl :: CompTypeRef -> [CTypeSpec]
exportCompTypeDecl ty = [CSUType (exportComp ty) ni]
    where
    exportComp (CompTypeRef sue_ref comp_tag _n) =
        CStruct (if comp_tag == StructTag then CStructTag else CUnionTag)
                (exportSUERef sue_ref) Nothing [] ni

exportEnumTypeDecl :: EnumTypeRef -> [CTypeSpec]
exportEnumTypeDecl ty = [CEnumType (exportEnum ty) ni]
    where
    exportEnum (EnumTypeRef sue_ref _n) =
        CEnum (exportSUERef sue_ref) Nothing [] ni

exportCompType :: CompType -> [CTypeSpec]
exportCompType (CompType sue_ref comp_tag members attrs node_info) = [CSUType comp ni]
    where
    comp = CStruct (if comp_tag == StructTag then CStructTag else CUnionTag)
                   (exportSUERef sue_ref)
                   (Just (map exportMemberDecl members))
                   (exportAttrs attrs)
                   node_info
exportCompTypeRef :: CompType -> [CTypeSpec]
exportCompTypeRef (CompType sue_ref com_tag  _ _ node_info) = exportCompTypeDecl (CompTypeRef sue_ref com_tag node_info)

exportEnumType :: EnumType -> [CTypeSpec]
exportEnumType (EnumType sue_ref enumerators attrs node_info) = [CEnumType enum ni]
    where
    enum = CEnum (exportSUERef sue_ref)
                 (Just (map exportEnumerator enumerators))
                 (exportAttrs attrs)
                 node_info
    exportEnumerator (Enumerator ident val _ty _) = (ident,Just val)

exportEnumTypeRef :: EnumType -> [CTypeSpec]
exportEnumTypeRef (EnumType sue_ref _ _ node_info) = exportEnumTypeDecl (EnumTypeRef sue_ref node_info)

-- XXX: relies on a the source program not having any $'s in it
exportSUERef :: SUERef -> Maybe Ident
exportSUERef (AnonymousRef name) = Just (internalIdent $ "$" ++ show (nameId name))
exportSUERef (NamedRef ident) = Just ident

exportMemberDecl :: MemberDecl -> CDecl
exportMemberDecl (AnonBitField ty expr node_info) =
    CDecl (map CTypeSpec $ exportTypeSpec $ fromDirectType ty) [(Nothing,Nothing,Just expr)] node_info
exportMemberDecl (MemberDecl vardecl bitfieldsz node_info) =
    let (specs,declarator) = exportVarDecl vardecl
    in  CDecl specs [(Just declarator, Nothing, bitfieldsz)] node_info
exportVarDecl :: VarDecl -> ([CDeclSpec],CDeclr)

-- NOTE: that there is an ambiguity between two possible places for __attributes__ s here
exportVarDecl (VarDecl name attrs ty) = exportDeclr (exportDeclAttrs attrs) ty [] name
exportParamDecl :: ParamDecl -> CDecl
exportParamDecl paramdecl =
    let (specs,declr) = exportVarDecl (getVarDecl paramdecl)
    in CDecl specs [(Just declr, Nothing , Nothing) ] (nodeInfo paramdecl)

exportDeclAttrs :: DeclAttrs -> [CDeclSpec]
exportDeclAttrs (DeclAttrs inline storage attrs) =
       (if inline then [CTypeQual (CInlineQual ni)] else [])
    ++ map (CStorageSpec) (exportStorage storage)
    ++ map (CTypeQual . CAttrQual) (exportAttrs attrs)

-- | express storage in terms of storage specifiers.
--
-- This isn't always possible and depends on the context the identifier is declared.
-- Most importantly, if there is a /conflicting/ declaration in scope, export is impossible.
-- Furthermore, automatic storage is impossible in file scope.
-- If the storage can actually be specified, the export is correct.
exportStorage :: Storage -> [CStorageSpec]
exportStorage NoStorage = []
exportStorage (Auto reg) = if reg then [CRegister ni] else []
exportStorage (Static InternalLinkage thread_local) = threadLocal thread_local [CStatic ni]
exportStorage (Static ExternalLinkage thread_local) = threadLocal thread_local [CExtern ni]
exportStorage (Static NoLinkage _) = error "impossible storage: static without linkage"
exportStorage (FunLinkage InternalLinkage) = [CStatic ni]
exportStorage (FunLinkage ExternalLinkage) = []
exportStorage (FunLinkage NoLinkage) = error "impossible storage: function without linkage"

threadLocal :: Bool -> [CStorageSpec] -> [CStorageSpec]
threadLocal False = id
threadLocal True = ((CThread ni) :)

exportAttrs :: [Attr] -> [CAttr]
exportAttrs = map exportAttr where
    exportAttr (Attr ident es n) = CAttr ident es n

fromDirectType :: Type -> TypeName
fromDirectType (DirectType ty _ _) = ty
fromDirectType (TypeDefType (TypeDefRef _ ref _) _ _) = maybe (error "undefined typeDef") fromDirectType ref
fromDirectType _ = error "fromDirectType"

ni :: NodeInfo
ni = undefNode