{-# LANGUAGE FlexibleInstances, CPP #-}
module Language.C.Analysis.TypeCheck where

import Control.Monad
import Data.Maybe
import Language.C.Data.Ident
import Language.C.Data.Node
import Language.C.Data.Position
import Language.C.Pretty
import Language.C.Syntax.AST
import Language.C.Syntax.Constants
import Language.C.Syntax.Ops
import Language.C.Analysis.DefTable
import Language.C.Analysis.SemRep
import Language.C.Analysis.TravMonad
import Language.C.Analysis.TypeConversions
import Language.C.Analysis.TypeUtils
import Language.C.Analysis.Debug ()
import Text.PrettyPrint.HughesPJ

-- We used to re-implement and export the standard Either instance for
-- Monad, which is bad, because as of GHC 7 it is in Control.Monad.Instances
-- in base >4.2. For backwards compatibility with ghc-6.X, we use CPP here.
#if __GLASGOW_HASKELL__ < 700
instance Monad (Either String) where
    return        = Right
    Left  l >>= _ = Left l
    Right r >>= k = k r
    fail msg      = Left msg
#endif

pType :: Type -> String
pType :: Type -> String
pType = Doc -> String
render (Doc -> String) -> (Type -> Doc) -> Type -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Doc
forall p. Pretty p => p -> Doc
pretty

typeErrorOnLeft :: (MonadCError m) => NodeInfo -> Either String a -> m a
typeErrorOnLeft :: forall (m :: * -> *) a.
MonadCError m =>
NodeInfo -> Either String a -> m a
typeErrorOnLeft NodeInfo
ni (Left String
err) = NodeInfo -> String -> m a
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
typeError NodeInfo
ni String
err
typeErrorOnLeft NodeInfo
_  (Right a
v)  = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v

-- XXX: this should use a custom error type, but typeMismatch isn't always right
typeError :: MonadCError m => NodeInfo -> String -> m a
typeError :: forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
typeError = NodeInfo -> String -> m a
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError

notFound :: Ident -> Either String a
notFound :: forall a. Ident -> Either String a
notFound Ident
i = String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$ String
"not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToString Ident
i

checkScalar' :: MonadCError m => NodeInfo -> Type -> m ()
checkScalar' :: forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkScalar' NodeInfo
ni = NodeInfo -> Either String () -> m ()
forall (m :: * -> *) a.
MonadCError m =>
NodeInfo -> Either String a -> m a
typeErrorOnLeft NodeInfo
ni (Either String () -> m ())
-> (Type -> Either String ()) -> Type -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Either String ()
checkScalar

checkIntegral' :: MonadCError m => NodeInfo -> Type -> m ()
checkIntegral' :: forall (m :: * -> *). MonadCError m => NodeInfo -> Type -> m ()
checkIntegral' NodeInfo
ni = NodeInfo -> Either String () -> m ()
forall (m :: * -> *) a.
MonadCError m =>
NodeInfo -> Either String a -> m a
typeErrorOnLeft NodeInfo
ni (Either String () -> m ())
-> (Type -> Either String ()) -> Type -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Either String ()
checkIntegral

assignCompatible' :: MonadCError m =>
                     NodeInfo -> CAssignOp -> Type -> Type -> m ()
assignCompatible' :: forall (m :: * -> *).
MonadCError m =>
NodeInfo -> CAssignOp -> Type -> Type -> m ()
assignCompatible' NodeInfo
ni CAssignOp
op Type
t1 Type
t2 = NodeInfo -> Either String () -> m ()
forall (m :: * -> *) a.
MonadCError m =>
NodeInfo -> Either String a -> m a
typeErrorOnLeft NodeInfo
ni (CAssignOp -> Type -> Type -> Either String ()
assignCompatible CAssignOp
op Type
t1 Type
t2)

binopType' :: MonadCError m =>
              NodeInfo -> CBinaryOp -> Type -> Type -> m Type
binopType' :: forall (m :: * -> *).
MonadCError m =>
NodeInfo -> CBinaryOp -> Type -> Type -> m Type
binopType' NodeInfo
ni CBinaryOp
op Type
t1 Type
t2 = NodeInfo -> Either String Type -> m Type
forall (m :: * -> *) a.
MonadCError m =>
NodeInfo -> Either String a -> m a
typeErrorOnLeft NodeInfo
ni (CBinaryOp -> Type -> Type -> Either String Type
binopType CBinaryOp
op Type
t1 Type
t2)

conditionalType' :: MonadCError m => NodeInfo -> Type -> Type -> m Type
conditionalType' :: forall (m :: * -> *).
MonadCError m =>
NodeInfo -> Type -> Type -> m Type
conditionalType' NodeInfo
ni Type
t1 Type
t2 = NodeInfo -> Either String Type -> m Type
forall (m :: * -> *) a.
MonadCError m =>
NodeInfo -> Either String a -> m a
typeErrorOnLeft NodeInfo
ni (Either String Type -> m Type) -> Either String Type -> m Type
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Either String Type
conditionalType Type
t1 Type
t2

checkScalar :: Type -> Either String ()
checkScalar :: Type -> Either String ()
checkScalar Type
t =
  case Type -> Type
canonicalType Type
t of
    DirectType TypeName
_ TypeQuals
_ Attributes
_  -> () -> Either String ()
forall a b. b -> Either a b
Right ()
    PtrType Type
_ TypeQuals
_ Attributes
_     -> () -> Either String ()
forall a b. b -> Either a b
Right ()
    ArrayType Type
_ ArraySize
_ TypeQuals
_ Attributes
_ -> () -> Either String ()
forall a b. b -> Either a b
Right () -- because it's just a pointer
    Type
t' -> String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$
          String
"expected scalar type, got: "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

checkIntegral :: Type -> Either String ()
checkIntegral :: Type -> Either String ()
checkIntegral Type
t | Type -> Bool
isIntegralType (Type -> Type
canonicalType Type
t) = () -> Either String ()
forall a b. b -> Either a b
Right ()
                | Bool
otherwise = String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$
                              String
"expected integral type, got: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                              Type -> String
pType Type
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                              Type -> String
pType (Type -> Type
canonicalType Type
t) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

-- | Determine the type of a constant.
constType :: (MonadCError m, MonadName m) => CConst -> m Type
constType :: forall (m :: * -> *).
(MonadCError m, MonadName m) =>
CConst -> m Type
constType (CIntConst (CInteger Integer
_ CIntRepr
_ Flags CIntFlag
flags) NodeInfo
_) =
  Type -> m Type
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> m Type) -> Type -> m Type
forall a b. (a -> b) -> a -> b
$ TypeName -> TypeQuals -> Attributes -> Type
DirectType (IntType -> TypeName
TyIntegral (Flags CIntFlag -> IntType
getIntType Flags CIntFlag
flags)) TypeQuals
noTypeQuals Attributes
noAttributes
constType (CCharConst (CChar Char
_ Bool
True) NodeInfo
_) =
  Type -> m Type
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> m Type) -> Type -> m Type
forall a b. (a -> b) -> a -> b
$ TypeName -> TypeQuals -> Attributes -> Type
DirectType (IntType -> TypeName
TyIntegral IntType
TyInt) TypeQuals
noTypeQuals Attributes
noAttributes
constType (CCharConst (CChar Char
_ Bool
False) NodeInfo
_) =
  Type -> m Type
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> m Type) -> Type -> m Type
forall a b. (a -> b) -> a -> b
$ TypeName -> TypeQuals -> Attributes -> Type
DirectType (IntType -> TypeName
TyIntegral IntType
TyChar) TypeQuals
noTypeQuals Attributes
noAttributes
constType (CCharConst (CChars String
_ Bool
_) NodeInfo
_)  =
  Type -> m Type
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> m Type) -> Type -> m Type
forall a b. (a -> b) -> a -> b
$ TypeName -> TypeQuals -> Attributes -> Type
DirectType (IntType -> TypeName
TyIntegral IntType
TyInt) TypeQuals
noTypeQuals Attributes
noAttributes -- XXX
constType (CFloatConst (CFloat String
fs) NodeInfo
_) =
  Type -> m Type
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> m Type) -> Type -> m Type
forall a b. (a -> b) -> a -> b
$ TypeName -> TypeQuals -> Attributes -> Type
DirectType (FloatType -> TypeName
TyFloating (String -> FloatType
getFloatType String
fs)) TypeQuals
noTypeQuals Attributes
noAttributes
-- XXX: should strings have any type qualifiers or attributes?
constType (CStrConst (CString String
chars Bool
wide) NodeInfo
ni) =
  do Name
n <- m Name
forall (m :: * -> *). MonadName m => m Name
genName
     let charType :: IntType
charType | Bool
wide      = IntType
TyInt -- XXX: this isn't universal
                  | Bool
otherwise = IntType
TyChar
         ni' :: NodeInfo
ni' = Position -> Name -> NodeInfo
mkNodeInfo (NodeInfo -> Position
forall a. Pos a => a -> Position
posOf NodeInfo
ni) Name
n
         arraySize :: ArraySize
arraySize = Bool -> CExpr -> ArraySize
ArraySize
                     Bool
True -- XXX: is it static?
                     (CConst -> CExpr
forall a. CConstant a -> CExpression a
CConst
                      (CInteger -> NodeInfo -> CConst
forall a. CInteger -> a -> CConstant a
CIntConst
                       (Integer -> CInteger
cInteger (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
chars))) NodeInfo
ni'))
     Type -> m Type
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> m Type) -> Type -> m Type
forall a b. (a -> b) -> a -> b
$ Type -> ArraySize -> TypeQuals -> Attributes -> Type
ArrayType (TypeName -> TypeQuals -> Attributes -> Type
DirectType (IntType -> TypeName
TyIntegral IntType
charType) TypeQuals
noTypeQuals Attributes
noAttributes)
                        ArraySize
arraySize TypeQuals
noTypeQuals []

-- | Determine whether two types are compatible.
compatible :: Type -> Type -> Either String ()
compatible :: Type -> Type -> Either String ()
compatible Type
t1 Type
t2 = Either String Type -> Either String ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void(Either String Type -> Either String ())
-> Either String Type -> Either String ()
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Either String Type
compositeType Type
t1 Type
t2

-- | Determine the composite type of two compatible types.
compositeType :: Type -> Type -> Either String Type
compositeType :: Type -> Type -> Either String Type
compositeType Type
t1 (DirectType (TyBuiltin BuiltinType
TyAny) TypeQuals
_ Attributes
_) = Type -> Either String Type
forall a b. b -> Either a b
Right Type
t1
compositeType (DirectType (TyBuiltin BuiltinType
TyAny) TypeQuals
_ Attributes
_) Type
t2 = Type -> Either String Type
forall a b. b -> Either a b
Right Type
t2
compositeType t1 :: Type
t1@(DirectType TypeName
tn1 TypeQuals
q1 Attributes
a1) t2 :: Type
t2@(DirectType TypeName
tn2 TypeQuals
q2 Attributes
a2) =
  do TypeName
tn <- case (TypeName
tn1, TypeName
tn2) of
             (TypeName
TyVoid, TypeName
TyVoid) -> TypeName -> Either String TypeName
forall a b. b -> Either a b
Right TypeName
TyVoid
             (TyIntegral IntType
_, TyEnum EnumTypeRef
_) -> TypeName -> Either String TypeName
forall a b. b -> Either a b
Right TypeName
tn1
             (TyEnum EnumTypeRef
_, TyIntegral IntType
_) -> TypeName -> Either String TypeName
forall a b. b -> Either a b
Right TypeName
tn2
             (TyIntegral IntType
i1, TyIntegral IntType
i2) ->
               TypeName -> Either String TypeName
forall a b. b -> Either a b
Right (TypeName -> Either String TypeName)
-> TypeName -> Either String TypeName
forall a b. (a -> b) -> a -> b
$ IntType -> TypeName
TyIntegral (IntType -> IntType -> IntType
intConversion IntType
i1 IntType
i2)
             (TyFloating FloatType
f1, TyFloating FloatType
f2) ->
               TypeName -> Either String TypeName
forall a b. b -> Either a b
Right (TypeName -> Either String TypeName)
-> TypeName -> Either String TypeName
forall a b. (a -> b) -> a -> b
$ FloatType -> TypeName
TyFloating (FloatType -> FloatType -> FloatType
floatConversion FloatType
f1 FloatType
f2)
             (TyComplex FloatType
f1, TyComplex FloatType
f2) ->
               TypeName -> Either String TypeName
forall a b. b -> Either a b
Right (TypeName -> Either String TypeName)
-> TypeName -> Either String TypeName
forall a b. (a -> b) -> a -> b
$ FloatType -> TypeName
TyComplex (FloatType -> FloatType -> FloatType
floatConversion FloatType
f1 FloatType
f2)
             (TyComp CompTypeRef
c1, TyComp CompTypeRef
c2) ->
               do Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CompTypeRef -> SUERef
forall a. HasSUERef a => a -> SUERef
sueRef CompTypeRef
c1 SUERef -> SUERef -> Bool
forall a. Eq a => a -> a -> Bool
/= CompTypeRef -> SUERef
forall a. HasSUERef a => a -> SUERef
sueRef CompTypeRef
c2) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
                       String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ String
"incompatible composite types: "
                              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t2
                  TypeName -> Either String TypeName
forall a b. b -> Either a b
Right TypeName
tn1
             (TyEnum EnumTypeRef
e1, TyEnum EnumTypeRef
e2) ->
               do Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EnumTypeRef -> SUERef
forall a. HasSUERef a => a -> SUERef
sueRef EnumTypeRef
e1 SUERef -> SUERef -> Bool
forall a. Eq a => a -> a -> Bool
/= EnumTypeRef -> SUERef
forall a. HasSUERef a => a -> SUERef
sueRef EnumTypeRef
e2) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
                       String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ String
"incompatible enumeration types: "
                              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t2
                  TypeName -> Either String TypeName
forall a b. b -> Either a b
Right (TypeName -> Either String TypeName)
-> TypeName -> Either String TypeName
forall a b. (a -> b) -> a -> b
$ EnumTypeRef -> TypeName
TyEnum EnumTypeRef
e1
             (TyBuiltin BuiltinType
TyVaList, TyBuiltin BuiltinType
TyVaList) ->
               TypeName -> Either String TypeName
forall a b. b -> Either a b
Right (TypeName -> Either String TypeName)
-> TypeName -> Either String TypeName
forall a b. (a -> b) -> a -> b
$ BuiltinType -> TypeName
TyBuiltin BuiltinType
TyVaList
             (TyBuiltin BuiltinType
_, TyBuiltin BuiltinType
_) ->
               String -> Either String TypeName
forall a b. a -> Either a b
Left (String -> Either String TypeName)
-> String -> Either String TypeName
forall a b. (a -> b) -> a -> b
$ String
"incompatible builtin types: "
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t2
             (TypeName
_, TypeName
_) -> String -> Either String TypeName
forall a b. a -> Either a b
Left (String -> Either String TypeName)
-> String -> Either String TypeName
forall a b. (a -> b) -> a -> b
$ String
"incompatible direct types: "
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t2
     Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> Either String Type) -> Type -> Either String Type
forall a b. (a -> b) -> a -> b
$ TypeName -> TypeQuals -> Attributes -> Type
DirectType TypeName
tn (TypeQuals -> TypeQuals -> TypeQuals
mergeTypeQuals TypeQuals
q1 TypeQuals
q2) (Attributes -> Attributes -> Attributes
mergeAttributes Attributes
a1 Attributes
a2)
compositeType (PtrType Type
t1 TypeQuals
q1 Attributes
a1) (PtrType (DirectType TypeName
TyVoid TypeQuals
_ Attributes
_) TypeQuals
q2 Attributes
_) =
  Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> Either String Type) -> Type -> Either String Type
forall a b. (a -> b) -> a -> b
$ Type -> TypeQuals -> Attributes -> Type
PtrType Type
t1 (TypeQuals -> TypeQuals -> TypeQuals
mergeTypeQuals TypeQuals
q1 TypeQuals
q2) Attributes
a1
compositeType (PtrType (DirectType TypeName
TyVoid TypeQuals
_ Attributes
_) TypeQuals
q1 Attributes
_) (PtrType Type
t2 TypeQuals
q2 Attributes
a2) =
  Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> Either String Type) -> Type -> Either String Type
forall a b. (a -> b) -> a -> b
$ Type -> TypeQuals -> Attributes -> Type
PtrType Type
t2 (TypeQuals -> TypeQuals -> TypeQuals
mergeTypeQuals TypeQuals
q1 TypeQuals
q2) Attributes
a2
compositeType (PtrType Type
t1 TypeQuals
q1 Attributes
a1) Type
t2 | Type -> Bool
isIntegralType Type
t2 =
  Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> Either String Type) -> Type -> Either String Type
forall a b. (a -> b) -> a -> b
$ Type -> TypeQuals -> Attributes -> Type
PtrType Type
t1 (TypeQuals -> TypeQuals -> TypeQuals
mergeTypeQuals TypeQuals
q1 (Type -> TypeQuals
typeQuals Type
t2)) Attributes
a1
compositeType Type
t1 (PtrType Type
t2 TypeQuals
q2 Attributes
a2) | Type -> Bool
isIntegralType Type
t1 =
  Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> Either String Type) -> Type -> Either String Type
forall a b. (a -> b) -> a -> b
$ Type -> TypeQuals -> Attributes -> Type
PtrType Type
t2 (TypeQuals -> TypeQuals -> TypeQuals
mergeTypeQuals (Type -> TypeQuals
typeQuals Type
t1) TypeQuals
q2) Attributes
a2
compositeType (ArrayType Type
t1 ArraySize
_sz1 TypeQuals
q1 Attributes
a1) Type
t2 | Type -> Bool
isIntegralType Type
t2 =
  Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> Either String Type) -> Type -> Either String Type
forall a b. (a -> b) -> a -> b
$ Type -> TypeQuals -> Attributes -> Type
PtrType Type
t1 TypeQuals
q1 Attributes
a1
compositeType Type
t1 (ArrayType Type
t2 ArraySize
_sz2 TypeQuals
q2 Attributes
a2) | Type -> Bool
isIntegralType Type
t1 =
  Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> Either String Type) -> Type -> Either String Type
forall a b. (a -> b) -> a -> b
$ Type -> TypeQuals -> Attributes -> Type
PtrType Type
t2 TypeQuals
q2 Attributes
a2
compositeType (ArrayType Type
t1 ArraySize
s1 TypeQuals
q1 Attributes
a1) (ArrayType Type
t2 ArraySize
s2 TypeQuals
q2 Attributes
a2) =
  do Type
t <- Type -> Type -> Either String Type
compositeType Type
t1 Type
t2
     ArraySize
s <- ArraySize -> ArraySize -> Either String ArraySize
compositeSize ArraySize
s1 ArraySize
s2
     let quals :: TypeQuals
quals = TypeQuals -> TypeQuals -> TypeQuals
mergeTypeQuals TypeQuals
q1 TypeQuals
q2
         attrs :: Attributes
attrs = Attributes -> Attributes -> Attributes
mergeAttrs Attributes
a1 Attributes
a2
     Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> ArraySize -> TypeQuals -> Attributes -> Type
ArrayType Type
t ArraySize
s TypeQuals
quals Attributes
attrs)
compositeType Type
t1 Type
t2 | Type -> Bool
isPointerType Type
t1 Bool -> Bool -> Bool
&& Type -> Bool
isPointerType Type
t2 =
  do Type
t <- Type -> Type -> Either String Type
compositeType (Type -> Type
baseType Type
t1) (Type -> Type
baseType Type
t2)
     let quals :: TypeQuals
quals = TypeQuals -> TypeQuals -> TypeQuals
mergeTypeQuals (Type -> TypeQuals
typeQuals Type
t1) (Type -> TypeQuals
typeQuals Type
t2)
         attrs :: Attributes
attrs = Attributes -> Attributes -> Attributes
mergeAttrs (Type -> Attributes
typeAttrs Type
t1) (Type -> Attributes
typeAttrs Type
t2)
     Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> TypeQuals -> Attributes -> Type
PtrType Type
t TypeQuals
quals Attributes
attrs)
compositeType (TypeDefType TypeDefRef
tdr1 TypeQuals
_q1 Attributes
_a1) (TypeDefType TypeDefRef
tdr2 TypeQuals
_q2 Attributes
_a2) =
  case (TypeDefRef
tdr1, TypeDefRef
tdr2) of
    (TypeDefRef Ident
_ Type
t1 NodeInfo
_, TypeDefRef Ident
_ Type
t2 NodeInfo
_) ->
      Type -> Type -> Either String Type
compositeType Type
t1 Type
t2
compositeType (FunctionType FunType
ft1 Attributes
attrs1) (FunctionType FunType
ft2 Attributes
attrs2) =
  case (FunType
ft1, FunType
ft2) of
    (FunType Type
rt1 [ParamDecl]
args1 Bool
varargs1, FunType Type
rt2 [ParamDecl]
args2 Bool
varargs2) ->
      do {- when (length args1 /= length args2) $
              Left "different numbers of arguments in function types" -}
         [ParamDecl]
args <- (ParamDecl -> ParamDecl -> Either String ParamDecl)
-> [ParamDecl] -> [ParamDecl] -> Either String [ParamDecl]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM ParamDecl -> ParamDecl -> Either String ParamDecl
compositeParamDecl [ParamDecl]
args1 [ParamDecl]
args2
         Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
varargs1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
varargs2) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
              String -> Either String ()
forall a b. a -> Either a b
Left String
"incompatible varargs declarations"
         Type -> Type -> [ParamDecl] -> Bool -> Either String Type
doFunType Type
rt1 Type
rt2 [ParamDecl]
args Bool
varargs1
    (FunType Type
rt1 [ParamDecl]
args1 Bool
varargs1, FunTypeIncomplete Type
rt2) ->
      Type -> Type -> [ParamDecl] -> Bool -> Either String Type
doFunType Type
rt1 Type
rt2 [ParamDecl]
args1 Bool
varargs1
    (FunTypeIncomplete Type
rt1, FunType Type
rt2 [ParamDecl]
args2 Bool
varargs2) ->
      Type -> Type -> [ParamDecl] -> Bool -> Either String Type
doFunType Type
rt1 Type
rt2 [ParamDecl]
args2 Bool
varargs2
    (FunTypeIncomplete Type
rt1, FunTypeIncomplete Type
rt2) ->
      do Type
rt <- Type -> Type -> Either String Type
compositeType Type
rt1 Type
rt2
         Type -> Either String Type
forall a b. b -> Either a b
Right (FunType -> Attributes -> Type
FunctionType (Type -> FunType
FunTypeIncomplete Type
rt) (Attributes -> Attributes -> Attributes
mergeAttrs Attributes
attrs1 Attributes
attrs2))
  where doFunType :: Type -> Type -> [ParamDecl] -> Bool -> Either String Type
doFunType Type
rt1 Type
rt2 [ParamDecl]
args Bool
varargs =
          do Type
rt <- Type -> Type -> Either String Type
compositeType Type
rt1 Type
rt2
             Type -> Either String Type
forall a b. b -> Either a b
Right (FunType -> Attributes -> Type
FunctionType
                     (Type -> [ParamDecl] -> Bool -> FunType
FunType Type
rt [ParamDecl]
args Bool
varargs)
                     (Attributes -> Attributes -> Attributes
mergeAttrs Attributes
attrs1 Attributes
attrs2))
compositeType Type
t1 Type
t2 = String -> Either String Type
forall a b. a -> Either a b
Left (String -> Either String Type) -> String -> Either String Type
forall a b. (a -> b) -> a -> b
$ String
"incompatible types: "
                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t2

-- XXX: this may not be correct
compositeSize :: ArraySize -> ArraySize -> Either String ArraySize
compositeSize :: ArraySize -> ArraySize -> Either String ArraySize
compositeSize (UnknownArraySize Bool
_) ArraySize
s2 = ArraySize -> Either String ArraySize
forall a b. b -> Either a b
Right ArraySize
s2
compositeSize ArraySize
s1 (UnknownArraySize Bool
_) = ArraySize -> Either String ArraySize
forall a b. b -> Either a b
Right ArraySize
s1
compositeSize (ArraySize Bool
s1 CExpr
e1) (ArraySize Bool
s2 CExpr
e2)
  | Bool
s1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
s2 Bool -> Bool -> Bool
&& CExpr -> CExpr -> Bool
sizeEqual CExpr
e1 CExpr
e2 = ArraySize -> Either String ArraySize
forall a b. b -> Either a b
Right (ArraySize -> Either String ArraySize)
-> ArraySize -> Either String ArraySize
forall a b. (a -> b) -> a -> b
$ Bool -> CExpr -> ArraySize
ArraySize Bool
s1 CExpr
e1
  | Bool
otherwise = ArraySize -> Either String ArraySize
forall a b. b -> Either a b
Right (ArraySize -> Either String ArraySize)
-> ArraySize -> Either String ArraySize
forall a b. (a -> b) -> a -> b
$ Bool -> CExpr -> ArraySize
ArraySize Bool
s1 CExpr
e1
{-
    fail $ "incompatible array sizes: "
           ++ (render . pretty) e1 ++ ", " ++ (render . pretty) e2
-}

sizeEqual :: CExpr -> CExpr -> Bool
sizeEqual :: CExpr -> CExpr -> Bool
sizeEqual (CConst (CIntConst CInteger
i1 NodeInfo
_)) (CConst (CIntConst CInteger
i2 NodeInfo
_)) = CInteger
i1 CInteger -> CInteger -> Bool
forall a. Eq a => a -> a -> Bool
== CInteger
i2
sizeEqual CExpr
e1 CExpr
e2 = CExpr -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo CExpr
e1 NodeInfo -> NodeInfo -> Bool
forall a. Eq a => a -> a -> Bool
== CExpr -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo CExpr
e2

mergeAttrs :: Attributes -> Attributes -> Attributes
mergeAttrs :: Attributes -> Attributes -> Attributes
mergeAttrs = Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
(++) -- XXX: ultimately this should be smarter

compositeParamDecl :: ParamDecl -> ParamDecl -> Either String ParamDecl
compositeParamDecl :: ParamDecl -> ParamDecl -> Either String ParamDecl
compositeParamDecl (ParamDecl VarDecl
vd1 NodeInfo
ni1) (ParamDecl VarDecl
vd2 NodeInfo
_) =
  (VarDecl -> NodeInfo -> ParamDecl)
-> VarDecl -> VarDecl -> NodeInfo -> Either String ParamDecl
compositeParamDecl' VarDecl -> NodeInfo -> ParamDecl
ParamDecl VarDecl
vd1 VarDecl
vd2 NodeInfo
ni1
compositeParamDecl (AbstractParamDecl VarDecl
vd1 NodeInfo
_) (ParamDecl VarDecl
vd2 NodeInfo
ni2) =
  (VarDecl -> NodeInfo -> ParamDecl)
-> VarDecl -> VarDecl -> NodeInfo -> Either String ParamDecl
compositeParamDecl' VarDecl -> NodeInfo -> ParamDecl
ParamDecl VarDecl
vd1 VarDecl
vd2 NodeInfo
ni2
compositeParamDecl (ParamDecl VarDecl
vd1 NodeInfo
ni1) (AbstractParamDecl VarDecl
vd2 NodeInfo
_) =
  (VarDecl -> NodeInfo -> ParamDecl)
-> VarDecl -> VarDecl -> NodeInfo -> Either String ParamDecl
compositeParamDecl' VarDecl -> NodeInfo -> ParamDecl
ParamDecl VarDecl
vd1 VarDecl
vd2 NodeInfo
ni1
compositeParamDecl (AbstractParamDecl VarDecl
vd1 NodeInfo
ni1) (AbstractParamDecl VarDecl
vd2 NodeInfo
_) =
  (VarDecl -> NodeInfo -> ParamDecl)
-> VarDecl -> VarDecl -> NodeInfo -> Either String ParamDecl
compositeParamDecl' VarDecl -> NodeInfo -> ParamDecl
AbstractParamDecl VarDecl
vd1 VarDecl
vd2 NodeInfo
ni1

compositeParamDecl' :: (VarDecl -> NodeInfo -> ParamDecl)
                    -> VarDecl
                    -> VarDecl
                    -> NodeInfo
                    -> Either String ParamDecl
compositeParamDecl' :: (VarDecl -> NodeInfo -> ParamDecl)
-> VarDecl -> VarDecl -> NodeInfo -> Either String ParamDecl
compositeParamDecl' VarDecl -> NodeInfo -> ParamDecl
f (VarDecl VarName
n1 DeclAttrs
attrs1 Type
t1) (VarDecl VarName
n2 DeclAttrs
attrs2 Type
t2) NodeInfo
dni =
  do VarDecl
vd <- VarDecl -> VarDecl -> Either String VarDecl
compositeVarDecl (VarName -> DeclAttrs -> Type -> VarDecl
VarDecl VarName
n1 DeclAttrs
attrs1 Type
t1') (VarName -> DeclAttrs -> Type -> VarDecl
VarDecl VarName
n2 DeclAttrs
attrs2 Type
t2')
     ParamDecl -> Either String ParamDecl
forall a b. b -> Either a b
Right (ParamDecl -> Either String ParamDecl)
-> ParamDecl -> Either String ParamDecl
forall a b. (a -> b) -> a -> b
$ VarDecl -> NodeInfo -> ParamDecl
f VarDecl
vd NodeInfo
dni
  where t1' :: Type
t1' = Type -> Type
canonicalType Type
t1
        t2' :: Type
t2' = Type -> Type
canonicalType Type
t2

compositeVarDecl :: VarDecl -> VarDecl -> Either String VarDecl
compositeVarDecl :: VarDecl -> VarDecl -> Either String VarDecl
compositeVarDecl (VarDecl VarName
n1 DeclAttrs
attrs1 Type
t1) (VarDecl VarName
_ DeclAttrs
attrs2 Type
t2) =
  do Type
t <- Type -> Type -> Either String Type
compositeType Type
t1 Type
t2
     VarDecl -> Either String VarDecl
forall a b. b -> Either a b
Right (VarName -> DeclAttrs -> Type -> VarDecl
VarDecl VarName
n1 (DeclAttrs -> DeclAttrs -> DeclAttrs
compositeDeclAttrs DeclAttrs
attrs1 DeclAttrs
attrs2) Type
t)

-- XXX: bad treatement of inline and storage
compositeDeclAttrs :: DeclAttrs -> DeclAttrs -> DeclAttrs
compositeDeclAttrs :: DeclAttrs -> DeclAttrs -> DeclAttrs
compositeDeclAttrs (DeclAttrs FunctionAttrs
inl Storage
stor Attributes
attrs1) (DeclAttrs FunctionAttrs
_ Storage
_ Attributes
attrs2) =
  FunctionAttrs -> Storage -> Attributes -> DeclAttrs
DeclAttrs FunctionAttrs
inl Storage
stor (Attributes -> Attributes -> Attributes
mergeAttrs Attributes
attrs1 Attributes
attrs2)

castCompatible :: Type -> Type -> Either String ()
castCompatible :: Type -> Type -> Either String ()
castCompatible Type
t1 Type
t2 =
  case (Type -> Type
canonicalType Type
t1, Type -> Type
canonicalType Type
t2) of
    (DirectType TypeName
TyVoid TypeQuals
_ Attributes
_, Type
_) -> () -> Either String ()
forall a b. b -> Either a b
Right ()
    (Type
_, Type
_) -> Type -> Either String ()
checkScalar Type
t1 Either String () -> Either String () -> Either String ()
forall a b. Either String a -> Either String b -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> Either String ()
checkScalar Type
t2

-- | Determine whether two types are compatible in an assignment expression.
assignCompatible :: CAssignOp -> Type -> Type -> Either String ()
assignCompatible :: CAssignOp -> Type -> Type -> Either String ()
assignCompatible CAssignOp
CAssignOp Type
t1 Type
t2 =
  case (Type -> Type
canonicalType Type
t1, Type -> Type
canonicalType Type
t2) of
    (DirectType (TyBuiltin BuiltinType
TyAny) TypeQuals
_ Attributes
_, Type
_) -> () -> Either String ()
forall a b. b -> Either a b
Right ()
    (Type
_, DirectType (TyBuiltin BuiltinType
TyAny) TypeQuals
_ Attributes
_) -> () -> Either String ()
forall a b. b -> Either a b
Right ()
    -- XXX: check qualifiers
    (PtrType (DirectType TypeName
TyVoid TypeQuals
_ Attributes
_) TypeQuals
_ Attributes
_, Type
t2') | Type -> Bool
isPointerType Type
t2' -> () -> Either String ()
forall a b. b -> Either a b
Right ()
    -- XXX: check qualifiers
    (Type
t1', PtrType (DirectType TypeName
TyVoid TypeQuals
_ Attributes
_) TypeQuals
_ Attributes
_) | Type -> Bool
isPointerType Type
t1' -> () -> Either String ()
forall a b. b -> Either a b
Right ()
    (PtrType Type
_ TypeQuals
_ Attributes
_, Type
t2') | Type -> Bool
isIntegralType Type
t2' -> () -> Either String ()
forall a b. b -> Either a b
Right ()
    (Type
t1', Type
t2') | Type -> Bool
isPointerType Type
t1' Bool -> Bool -> Bool
&& Type -> Bool
isPointerType Type
t2' ->
                 Type -> Type -> Either String ()
compatible (Type -> Type
baseType Type
t1') (Type -> Type
baseType Type
t2')
                --unless (typeQuals t2 <= typeQuals t1) $
                --       Left $
                --       "incompatible qualifiers in pointer assignment: "
                --       ++ pType t1 ++ ", " ++ pType t2
    (DirectType (TyComp CompTypeRef
c1) TypeQuals
_ Attributes
_, DirectType (TyComp CompTypeRef
c2) TypeQuals
_ Attributes
_)
      | CompTypeRef -> SUERef
forall a. HasSUERef a => a -> SUERef
sueRef CompTypeRef
c1 SUERef -> SUERef -> Bool
forall a. Eq a => a -> a -> Bool
== CompTypeRef -> SUERef
forall a. HasSUERef a => a -> SUERef
sueRef CompTypeRef
c2 -> () -> Either String ()
forall a b. b -> Either a b
Right ()
      | Bool
otherwise -> String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$
                     String
"incompatible compound types in assignment: "
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t2
    (DirectType (TyBuiltin BuiltinType
TyVaList) TypeQuals
_ Attributes
_, DirectType (TyBuiltin BuiltinType
TyVaList) TypeQuals
_ Attributes
_) ->
      () -> Either String ()
forall a b. b -> Either a b
Right ()
    (DirectType TypeName
tn1 TypeQuals
_ Attributes
_, DirectType TypeName
tn2 TypeQuals
_ Attributes
_)
      | Maybe TypeName -> Bool
forall a. Maybe a -> Bool
isJust (TypeName -> TypeName -> Maybe TypeName
arithmeticConversion TypeName
tn1 TypeName
tn2) -> () -> Either String ()
forall a b. b -> Either a b
Right ()
      | Bool
otherwise -> String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ String
"incompatible direct types in assignment: "
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t2
    (Type
t1', Type
t2') -> Type -> Type -> Either String ()
compatible Type
t1' Type
t2'
assignCompatible CAssignOp
op Type
t1 Type
t2 = Either String Type -> Either String ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void(Either String Type -> Either String ())
-> Either String Type -> Either String ()
forall a b. (a -> b) -> a -> b
$ CBinaryOp -> Type -> Type -> Either String Type
binopType (CAssignOp -> CBinaryOp
assignBinop CAssignOp
op) Type
t1 Type
t2

-- | Determine the type of a binary operation.
binopType :: CBinaryOp -> Type -> Type -> Either String Type
binopType :: CBinaryOp -> Type -> Type -> Either String Type
binopType CBinaryOp
op Type
t1 Type
t2 =
  case (CBinaryOp
op, Type -> Type
canonicalType Type
t1, Type -> Type
canonicalType Type
t2) of
    (CBinaryOp
_, Type
t1', Type
t2')
      | CBinaryOp -> Bool
isLogicOp CBinaryOp
op ->
        Type -> Either String ()
checkScalar Type
t1' Either String () -> Either String () -> Either String ()
forall a b. Either String a -> Either String b -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> Either String ()
checkScalar Type
t2' Either String () -> Either String Type -> Either String Type
forall a b. Either String a -> Either String b -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> Either String Type
forall a b. b -> Either a b
Right Type
boolType
      | CBinaryOp -> Bool
isCmpOp CBinaryOp
op ->
        case (Type
t1', Type
t2') of
          (DirectType TypeName
tn1 TypeQuals
_ Attributes
_, DirectType TypeName
tn2 TypeQuals
_ Attributes
_) ->
                case TypeName -> TypeName -> Maybe TypeName
arithmeticConversion TypeName
tn1 TypeName
tn2 of
                  Just TypeName
_ -> Type -> Either String Type
forall a b. b -> Either a b
Right Type
boolType
                  Maybe TypeName
Nothing -> String -> Either String Type
forall a b. a -> Either a b
Left (String -> Either String Type) -> String -> Either String Type
forall a b. (a -> b) -> a -> b
$ Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$
                             String -> Doc
text String
"incompatible arithmetic types in comparison: "
                             Doc -> Doc -> Doc
<+> Type -> Doc
forall p. Pretty p => p -> Doc
pretty Type
t1 Doc -> Doc -> Doc
<+> String -> Doc
text String
"and" Doc -> Doc -> Doc
<+> Type -> Doc
forall p. Pretty p => p -> Doc
pretty Type
t2
          (PtrType (DirectType TypeName
TyVoid TypeQuals
_ Attributes
_) TypeQuals
_ Attributes
_, Type
_)
            | Type -> Bool
isPointerType Type
t2' -> Type -> Either String Type
forall a b. b -> Either a b
Right Type
boolType
          (Type
_, PtrType (DirectType TypeName
TyVoid TypeQuals
_ Attributes
_) TypeQuals
_ Attributes
_)
            | Type -> Bool
isPointerType Type
t1' -> Type -> Either String Type
forall a b. b -> Either a b
Right Type
boolType
          (Type
_, Type
_)
            | Type -> Bool
isPointerType Type
t1' Bool -> Bool -> Bool
&& Type -> Bool
isIntegralType Type
t2' -> Type -> Either String Type
forall a b. b -> Either a b
Right Type
boolType
            | Type -> Bool
isIntegralType Type
t1' Bool -> Bool -> Bool
&& Type -> Bool
isPointerType Type
t2' -> Type -> Either String Type
forall a b. b -> Either a b
Right Type
boolType
            | Type -> Bool
isPointerType Type
t1' Bool -> Bool -> Bool
&& Type -> Bool
isPointerType Type
t2' ->
              Type -> Type -> Either String ()
compatible Type
t1' Type
t2' Either String () -> Either String Type -> Either String Type
forall a b. Either String a -> Either String b -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> Either String Type
forall a b. b -> Either a b
Right Type
boolType
          (Type
_, Type
_) -> String -> Either String Type
forall a b. a -> Either a b
Left String
"incompatible types in comparison"
    (CBinaryOp
CSubOp, ArrayType Type
t1' ArraySize
_ TypeQuals
_ Attributes
_, ArrayType Type
t2' ArraySize
_ TypeQuals
_ Attributes
_) ->
      Type -> Type -> Either String ()
compatible Type
t1' Type
t2' Either String () -> Either String Type -> Either String Type
forall a b. Either String a -> Either String b -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> Either String Type
forall a b. b -> Either a b
Right Type
ptrDiffType
    (CBinaryOp
CSubOp, ArrayType Type
t1' ArraySize
_ TypeQuals
_ Attributes
_, PtrType Type
t2' TypeQuals
_ Attributes
_) ->
      Type -> Type -> Either String ()
compatible Type
t1' Type
t2' Either String () -> Either String Type -> Either String Type
forall a b. Either String a -> Either String b -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> Either String Type
forall a b. b -> Either a b
Right Type
ptrDiffType
    (CBinaryOp
CSubOp, PtrType Type
t1' TypeQuals
_ Attributes
_, ArrayType Type
t2' ArraySize
_ TypeQuals
_ Attributes
_) ->
      Type -> Type -> Either String ()
compatible Type
t1' Type
t2' Either String () -> Either String Type -> Either String Type
forall a b. Either String a -> Either String b -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> Either String Type
forall a b. b -> Either a b
Right Type
ptrDiffType
    (CBinaryOp
CSubOp, PtrType Type
t1' TypeQuals
_ Attributes
_, PtrType Type
t2' TypeQuals
_ Attributes
_) ->
      Type -> Type -> Either String ()
compatible Type
t1' Type
t2' Either String () -> Either String Type -> Either String Type
forall a b. Either String a -> Either String b -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> Either String Type
forall a b. b -> Either a b
Right Type
ptrDiffType
    (CBinaryOp
_, PtrType Type
_ TypeQuals
_ Attributes
_, Type
t2')
      | CBinaryOp -> Bool
isPtrOp CBinaryOp
op Bool -> Bool -> Bool
&& Type -> Bool
isIntegralType Type
t2' -> Type -> Either String Type
forall a b. b -> Either a b
Right Type
t1
      | Bool
otherwise -> String -> Either String Type
forall a b. a -> Either a b
Left (String -> Either String Type) -> String -> Either String Type
forall a b. (a -> b) -> a -> b
$ String
"invalid pointer operation: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
render (CBinaryOp -> Doc
forall p. Pretty p => p -> Doc
pretty CBinaryOp
op)
    (CBinaryOp
CAddOp, Type
t1', PtrType Type
_ TypeQuals
_ Attributes
_) | Type -> Bool
isIntegralType Type
t1' -> Type -> Either String Type
forall a b. b -> Either a b
Right Type
t2
    (CBinaryOp
_, ArrayType Type
_ ArraySize
_ TypeQuals
_ Attributes
_, Type
t2')
      | CBinaryOp -> Bool
isPtrOp CBinaryOp
op Bool -> Bool -> Bool
&& Type -> Bool
isIntegralType Type
t2' -> Type -> Either String Type
forall a b. b -> Either a b
Right Type
t1
      | Bool
otherwise -> String -> Either String Type
forall a b. a -> Either a b
Left (String -> Either String Type) -> String -> Either String Type
forall a b. (a -> b) -> a -> b
$ String
"invalid pointer operation: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
render (CBinaryOp -> Doc
forall p. Pretty p => p -> Doc
pretty CBinaryOp
op)
    (CBinaryOp
CAddOp, Type
t1', ArrayType Type
_ ArraySize
_ TypeQuals
_ Attributes
_) | Type -> Bool
isIntegralType Type
t1' -> Type -> Either String Type
forall a b. b -> Either a b
Right Type
t2
    (CBinaryOp
_, DirectType TypeName
tn1 TypeQuals
q1 Attributes
a1, DirectType TypeName
tn2 TypeQuals
q2 Attributes
a2) ->
        do Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CBinaryOp -> Bool
isBitOp CBinaryOp
op) (Type -> Either String ()
checkIntegral Type
t1 Either String () -> Either String () -> Either String ()
forall a b. Either String a -> Either String b -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> Either String ()
checkIntegral Type
t2)
           case TypeName -> TypeName -> Maybe TypeName
arithmeticConversion TypeName
tn1 TypeName
tn2 of
             Just TypeName
tn -> Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> Either String Type) -> Type -> Either String Type
forall a b. (a -> b) -> a -> b
$ TypeName -> TypeQuals -> Attributes -> Type
DirectType TypeName
tn (TypeQuals -> TypeQuals -> TypeQuals
mergeTypeQuals TypeQuals
q1 TypeQuals
q2) (Attributes -> Attributes -> Attributes
mergeAttributes Attributes
a1 Attributes
a2)
             Maybe TypeName
Nothing -> String -> Either String Type
forall a b. a -> Either a b
Left (String -> Either String Type) -> String -> Either String Type
forall a b. (a -> b) -> a -> b
$ Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$
                        String -> Doc
text String
"invalid binary operation:" Doc -> Doc -> Doc
<+> Type -> Doc
forall p. Pretty p => p -> Doc
pretty Type
t1 Doc -> Doc -> Doc
<+> CBinaryOp -> Doc
forall p. Pretty p => p -> Doc
pretty CBinaryOp
op Doc -> Doc -> Doc
<+> Type -> Doc
forall p. Pretty p => p -> Doc
pretty Type
t2
    (CBinaryOp
_, Type
_, Type
_) -> String -> Either String Type
forall a b. a -> Either a b
Left (String -> Either String Type) -> String -> Either String Type
forall a b. (a -> b) -> a -> b
$ Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$
                 String -> Doc
text String
"unhandled binary operation:" Doc -> Doc -> Doc
<+> Type -> Doc
forall p. Pretty p => p -> Doc
pretty Type
t1 Doc -> Doc -> Doc
<+> CBinaryOp -> Doc
forall p. Pretty p => p -> Doc
pretty CBinaryOp
op Doc -> Doc -> Doc
<+> Type -> Doc
forall p. Pretty p => p -> Doc
pretty Type
t2

-- | Determine the type of a conditional expression.
conditionalType :: Type -> Type -> Either String Type
conditionalType :: Type -> Type -> Either String Type
conditionalType Type
t1 Type
t2 =
  case (Type -> Type
canonicalType Type
t1, Type -> Type
canonicalType Type
t2) of
    (PtrType (DirectType TypeName
TyVoid TypeQuals
_ Attributes
_) TypeQuals
_ Attributes
_, Type
t2') | Type -> Bool
isPointerType Type
t2' -> Type -> Either String Type
forall a b. b -> Either a b
Right Type
t2
    (Type
t1', PtrType (DirectType TypeName
TyVoid TypeQuals
_ Attributes
_) TypeQuals
_ Attributes
_) | Type -> Bool
isPointerType Type
t1' -> Type -> Either String Type
forall a b. b -> Either a b
Right Type
t1
    (ArrayType Type
t1' ArraySize
_ TypeQuals
q1 Attributes
a1, ArrayType Type
t2' ArraySize
_ TypeQuals
q2 Attributes
a2) ->
      do Type
t <- Type -> Type -> Either String Type
compositeType Type
t1' Type
t2'
         Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> Either String Type) -> Type -> Either String Type
forall a b. (a -> b) -> a -> b
$ Type -> ArraySize -> TypeQuals -> Attributes -> Type
ArrayType Type
t (Bool -> ArraySize
UnknownArraySize Bool
False)
                  (TypeQuals -> TypeQuals -> TypeQuals
mergeTypeQuals TypeQuals
q1 TypeQuals
q2) (Attributes -> Attributes -> Attributes
mergeAttrs Attributes
a1 Attributes
a2)
    (t1' :: Type
t1'@(DirectType TypeName
tn1 TypeQuals
q1 Attributes
a1), t2' :: Type
t2'@(DirectType TypeName
tn2 TypeQuals
q2 Attributes
a2)) ->
      case TypeName -> TypeName -> Maybe TypeName
arithmeticConversion TypeName
tn1 TypeName
tn2 of
        Just TypeName
tn -> Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> Either String Type) -> Type -> Either String Type
forall a b. (a -> b) -> a -> b
$ TypeName -> TypeQuals -> Attributes -> Type
DirectType TypeName
tn (TypeQuals -> TypeQuals -> TypeQuals
mergeTypeQuals TypeQuals
q1 TypeQuals
q2) (Attributes -> Attributes -> Attributes
mergeAttributes Attributes
a1 Attributes
a2)
        Maybe TypeName
Nothing -> Type -> Type -> Either String Type
compositeType Type
t1' Type
t2'
    (Type
t1', Type
t2') -> Type -> Type -> Either String Type
compositeType Type
t1' Type
t2'

derefType :: Type -> Either String Type
derefType :: Type -> Either String Type
derefType (PtrType Type
t TypeQuals
_ Attributes
_) = Type -> Either String Type
forall a b. b -> Either a b
Right Type
t
derefType (ArrayType Type
t ArraySize
_ TypeQuals
_ Attributes
_) = Type -> Either String Type
forall a b. b -> Either a b
Right Type
t
derefType Type
t =
  -- XXX: is it good to use canonicalType here?
  case Type -> Type
canonicalType Type
t of
    PtrType Type
t' TypeQuals
_ Attributes
_ -> Type -> Either String Type
forall a b. b -> Either a b
Right Type
t'
    ArrayType Type
t' ArraySize
_ TypeQuals
_ Attributes
_ -> Type -> Either String Type
forall a b. b -> Either a b
Right Type
t'
    Type
_ -> String -> Either String Type
forall a b. a -> Either a b
Left (String -> Either String Type) -> String -> Either String Type
forall a b. (a -> b) -> a -> b
$ String
"dereferencing non-pointer: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t

varAddrType :: IdentDecl -> Either String Type
varAddrType :: IdentDecl -> Either String Type
varAddrType IdentDecl
d =
  do case IdentDecl -> Storage
forall d. Declaration d => d -> Storage
declStorage IdentDecl
d of
       Auto Bool
True -> String -> Either String ()
forall a b. a -> Either a b
Left String
"address of register variable"
       Storage
_         -> () -> Either String ()
forall a b. b -> Either a b
Right ()
     case Type
t of
       ArrayType Type
_ ArraySize
_ TypeQuals
q Attributes
a -> Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> Either String Type) -> Type -> Either String Type
forall a b. (a -> b) -> a -> b
$ Type -> TypeQuals -> Attributes -> Type
PtrType Type
t TypeQuals
q Attributes
a
       Type
_                 -> Type -> Either String Type
forall a b. b -> Either a b
Right (Type -> Either String Type) -> Type -> Either String Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
simplePtr Type
t
  where t :: Type
t = IdentDecl -> Type
forall n. Declaration n => n -> Type
declType IdentDecl
d

-- | Get the type of field @m@ of type @t@
fieldType :: (MonadCError m, MonadSymtab m) => NodeInfo -> Ident -> Type -> m Type
fieldType :: forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> Ident -> Type -> m Type
fieldType NodeInfo
ni Ident
m Type
t =
  case Type -> Type
canonicalType Type
t of
    DirectType (TyComp CompTypeRef
ctr) TypeQuals
_ Attributes
_ ->
      do TagDef
td <- NodeInfo -> SUERef -> m TagDef
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> SUERef -> m TagDef
lookupSUE NodeInfo
ni (CompTypeRef -> SUERef
forall a. HasSUERef a => a -> SUERef
sueRef CompTypeRef
ctr)
         [(Ident, Type)]
ms <- NodeInfo -> TagDef -> m [(Ident, Type)]
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> TagDef -> m [(Ident, Type)]
tagMembers NodeInfo
ni TagDef
td
         case Ident -> [(Ident, Type)] -> Maybe Type
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Ident
m [(Ident, Type)]
ms of
           Just Type
ft -> Type -> m Type
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ft
           Maybe Type
Nothing -> NodeInfo -> String -> m Type
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
typeError NodeInfo
ni (String -> m Type) -> String -> m Type
forall a b. (a -> b) -> a -> b
$ String
"field not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToString Ident
m
    Type
_t' -> NodeInfo -> String -> m Type
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
ni (String -> m Type) -> String -> m Type
forall a b. (a -> b) -> a -> b
$
          String
"field of non-composite type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToString Ident
m
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
pType Type
t

-- | Get all members of a struct, union, or enum, with their
--   types. Collapse fields of anonymous members.
tagMembers :: (MonadCError m, MonadSymtab m) =>
              NodeInfo -> TagDef -> m [(Ident, Type)]
tagMembers :: forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> TagDef -> m [(Ident, Type)]
tagMembers NodeInfo
ni TagDef
td =
  case TagDef
td of
    CompDef (CompType SUERef
_ CompTyKind
_ [MemberDecl]
ms Attributes
_ NodeInfo
_) -> [MemberDecl] -> m [(Ident, Type)]
forall {m :: * -> *} {a}.
(MonadCError m, MonadSymtab m, Declaration a) =>
[a] -> m [(Ident, Type)]
getMembers [MemberDecl]
ms
    EnumDef (EnumType SUERef
_ [Enumerator]
es Attributes
_ NodeInfo
_) -> [Enumerator] -> m [(Ident, Type)]
forall {m :: * -> *} {a}.
(MonadCError m, MonadSymtab m, Declaration a) =>
[a] -> m [(Ident, Type)]
getMembers [Enumerator]
es
  where getMembers :: [a] -> m [(Ident, Type)]
getMembers [a]
ds =
          do let ts :: [Type]
ts = (a -> Type) -> [a] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map a -> Type
forall n. Declaration n => n -> Type
declType [a]
ds
                 ns :: [VarName]
ns = (a -> VarName) -> [a] -> [VarName]
forall a b. (a -> b) -> [a] -> [b]
map a -> VarName
forall n. Declaration n => n -> VarName
declName [a]
ds
             [[(Ident, Type)]] -> [(Ident, Type)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Ident, Type)]] -> [(Ident, Type)])
-> m [[(Ident, Type)]] -> m [(Ident, Type)]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` ((VarName, Type) -> m [(Ident, Type)])
-> [(VarName, Type)] -> m [[(Ident, Type)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (NodeInfo -> (VarName, Type) -> m [(Ident, Type)]
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> (VarName, Type) -> m [(Ident, Type)]
expandAnonymous NodeInfo
ni) ([VarName] -> [Type] -> [(VarName, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [VarName]
ns [Type]
ts)

-- | Expand an anonymous composite type into a list of member names
--   and their associated types.
expandAnonymous :: (MonadCError m, MonadSymtab m) =>
                   NodeInfo -> (VarName, Type)
                -> m [(Ident, Type)]
expandAnonymous :: forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> (VarName, Type) -> m [(Ident, Type)]
expandAnonymous NodeInfo
ni (VarName
NoName, DirectType (TyComp CompTypeRef
ctr) TypeQuals
_ Attributes
_) =
  NodeInfo -> SUERef -> m TagDef
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> SUERef -> m TagDef
lookupSUE NodeInfo
ni (CompTypeRef -> SUERef
forall a. HasSUERef a => a -> SUERef
sueRef CompTypeRef
ctr) m TagDef -> (TagDef -> m [(Ident, Type)]) -> m [(Ident, Type)]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NodeInfo -> TagDef -> m [(Ident, Type)]
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> TagDef -> m [(Ident, Type)]
tagMembers NodeInfo
ni
expandAnonymous NodeInfo
_ (VarName
NoName, Type
_) = [(Ident, Type)] -> m [(Ident, Type)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
expandAnonymous NodeInfo
_ (VarName Ident
n Maybe AsmName
_, Type
t) = [(Ident, Type)] -> m [(Ident, Type)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Ident
n, Type
t)]

lookupSUE :: (MonadCError m, MonadSymtab m) =>
             NodeInfo -> SUERef -> m TagDef
lookupSUE :: forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> SUERef -> m TagDef
lookupSUE NodeInfo
ni SUERef
sue =
  do DefTable
dt <- m DefTable
forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable
     case SUERef -> DefTable -> Maybe TagEntry
lookupTag SUERef
sue DefTable
dt of
       Just (Right TagDef
td) -> TagDef -> m TagDef
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return TagDef
td
       Maybe TagEntry
_               ->
         NodeInfo -> String -> m TagDef
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
typeError NodeInfo
ni (String -> m TagDef) -> String -> m TagDef
forall a b. (a -> b) -> a -> b
$ String
"unknown composite type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Doc -> String
render (Doc -> String) -> (SUERef -> Doc) -> SUERef -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SUERef -> Doc
forall p. Pretty p => p -> Doc
pretty) SUERef
sue

deepTypeAttrs :: (MonadCError m, MonadSymtab m) =>
                 Type -> m Attributes
deepTypeAttrs :: forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Type -> m Attributes
deepTypeAttrs (DirectType (TyComp (CompTypeRef SUERef
sue CompTyKind
_ NodeInfo
ni)) TypeQuals
_ Attributes
attrs) =
  (Attributes
attrs Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
++) (Attributes -> Attributes) -> m Attributes -> m Attributes
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` NodeInfo -> SUERef -> m Attributes
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> SUERef -> m Attributes
sueAttrs NodeInfo
ni SUERef
sue
deepTypeAttrs (DirectType (TyEnum (EnumTypeRef SUERef
sue NodeInfo
ni)) TypeQuals
_ Attributes
attrs) =
  (Attributes
attrs Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
++) (Attributes -> Attributes) -> m Attributes -> m Attributes
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` NodeInfo -> SUERef -> m Attributes
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> SUERef -> m Attributes
sueAttrs NodeInfo
ni SUERef
sue
deepTypeAttrs (DirectType TypeName
_ TypeQuals
_ Attributes
attrs) = Attributes -> m Attributes
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Attributes
attrs
deepTypeAttrs (PtrType Type
t TypeQuals
_ Attributes
attrs) = (Attributes
attrs Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
++) (Attributes -> Attributes) -> m Attributes -> m Attributes
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Type -> m Attributes
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Type -> m Attributes
deepTypeAttrs Type
t
deepTypeAttrs (ArrayType Type
t ArraySize
_ TypeQuals
_ Attributes
attrs) = (Attributes
attrs Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
++) (Attributes -> Attributes) -> m Attributes -> m Attributes
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Type -> m Attributes
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Type -> m Attributes
deepTypeAttrs Type
t
deepTypeAttrs (FunctionType (FunType Type
t [ParamDecl]
_ Bool
_) Attributes
attrs) =
  (Attributes
attrs Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
++) (Attributes -> Attributes) -> m Attributes -> m Attributes
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Type -> m Attributes
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Type -> m Attributes
deepTypeAttrs Type
t
deepTypeAttrs (FunctionType (FunTypeIncomplete Type
t)  Attributes
attrs) =
  (Attributes
attrs Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
++) (Attributes -> Attributes) -> m Attributes -> m Attributes
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Type -> m Attributes
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Type -> m Attributes
deepTypeAttrs Type
t
deepTypeAttrs (TypeDefType (TypeDefRef Ident
i Type
_ NodeInfo
ni) TypeQuals
_ Attributes
attrs) =
  (Attributes
attrs Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
++) (Attributes -> Attributes) -> m Attributes -> m Attributes
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` NodeInfo -> Ident -> m Attributes
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> Ident -> m Attributes
typeDefAttrs NodeInfo
ni Ident
i

typeDefAttrs :: (MonadCError m, MonadSymtab m) =>
                NodeInfo -> Ident -> m Attributes
typeDefAttrs :: forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> Ident -> m Attributes
typeDefAttrs NodeInfo
ni Ident
i =
  do DefTable
dt <- m DefTable
forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable
     case Ident -> DefTable -> Maybe IdentEntry
lookupIdent Ident
i DefTable
dt of
       Maybe IdentEntry
Nothing -> NodeInfo -> String -> m Attributes
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
ni (String -> m Attributes) -> String -> m Attributes
forall a b. (a -> b) -> a -> b
$ String
"can't find typedef name: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToString Ident
i
       Just (Left (TypeDef Ident
_ Type
t Attributes
attrs NodeInfo
_)) -> (Attributes
attrs Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
++) (Attributes -> Attributes) -> m Attributes -> m Attributes
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Type -> m Attributes
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Type -> m Attributes
deepTypeAttrs Type
t
       Just (Right IdentDecl
_) -> NodeInfo -> String -> m Attributes
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
ni (String -> m Attributes) -> String -> m Attributes
forall a b. (a -> b) -> a -> b
$ String
"not a typedef name: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToString Ident
i

sueAttrs :: (MonadCError m, MonadSymtab m) =>
            NodeInfo -> SUERef -> m Attributes
sueAttrs :: forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> SUERef -> m Attributes
sueAttrs NodeInfo
ni SUERef
sue =
  do DefTable
dt <- m DefTable
forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable
     case SUERef -> DefTable -> Maybe TagEntry
lookupTag SUERef
sue DefTable
dt of
       Maybe TagEntry
Nothing -> NodeInfo -> String -> m Attributes
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
ni (String -> m Attributes) -> String -> m Attributes
forall a b. (a -> b) -> a -> b
$ String
"SUE not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
render (SUERef -> Doc
forall p. Pretty p => p -> Doc
pretty SUERef
sue)
       Just (Left TagFwdDecl
_) -> Attributes -> m Attributes
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
       Just (Right (CompDef (CompType SUERef
_ CompTyKind
_ [MemberDecl]
_ Attributes
attrs NodeInfo
_))) -> Attributes -> m Attributes
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Attributes
attrs
       Just (Right (EnumDef (EnumType SUERef
_ [Enumerator]
_ Attributes
attrs NodeInfo
_))) -> Attributes -> m Attributes
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Attributes
attrs