%
% (c) The Foo Project, University of Glasgow, 1998
%
% @(#) $Docid: Jan. 30th 2003 14:19 Sigbjorn Finne $
% @(#) $Contactid: sof@galois.com $
%
Generating code for going between IDL enums and
their Haskell equivalent.
\begin{code}
module MarshallEnum
( marshallEnum
, genDerivedEnumInstanceFor
) where
import MarshallType
import BasicTypes ( BinaryOp(..),QualName, qName, EnumKind(..) )
import Literal ( iLit )
import AbstractH ( HDecl )
import qualified AbstractH as Haskell ( CaseAlt, Expr )
import CgMonad
import AbsHUtils
import LibUtils hiding ( enumToInt )
import qualified LibUtils ( enumToInt )
import CoreIDL
import CoreUtils ( mkHaskellTyConName )
import Attribute ( hasAttributeWithName, filterAttributes )
import Literal ( Literal(..) )
import Opts ( optSmartEnums, optNoVariantInstance,
optVariantInstance, optEnumsAsFlags,
optGenBitsInstance, optGenNumInstance
)
import PpCore ( ppEnumValue, showCore )
\end{code}
\begin{code}
marshallEnum :: Id -> EnumKind -> Bool -> [EnumValue] -> CgM HDecl
marshallEnum tdef_id kind noEnumInstance enums
| noEnumInstance && genVariantInstance = return variantInst
| noEnumInstance = return emptyDecl
| genVariantInstance = return (enumInst `andDecl` variantInst)
| otherwise = return enumInst
where
genVariantInstance = optVariantInstance && not optNoVariantInstance
attrs = idAttributes tdef_id
tdef_name = idName tdef_id
name = mkVarName tdef_name
v = var "v"
x1 = var "x1"
x2 = var "x2"
t_ty = tyConst (qName name)
enumInst =
addBitsInstance $
hInstance Nothing enumClass t_ty
[ methodDef fromEnumName [varPat v] m_rhs
, methodDef toEnumName [varPat v] u_rhs
]
variantInst =
hInstance Nothing variantClass t_ty
[ methodDef inVariantName [] inv_rhs
, methodDef resVariantName [] resv_rhs
, methodDef defaultVariantName [] def_rhs
, methodDef vtEltTypeName [] vt_elt_rhs
]
addBitsInstance d
| withListCon =
if optGenBitsInstance || optGenNumInstance then
(if optGenNumInstance then
numInstance
else
numInstance `andDecl` bitsInstance)
`andDecl` d
else
flagsInstance `andDecl` d
| otherwise = d
withListCon =
case kind of
EnumFlags{} -> True
_ -> forceFlag
forceFlag = optEnumsAsFlags || attrs `hasAttributeWithName` "hs_flag"
numInstance =
hInstance Nothing numClass t_ty
[ methodDef (mkQVarName prelude "+") [varPat x1, varPat x2] or_rhs
]
bitsInstance =
hInstance Nothing bitsClass t_ty
[ methodDef andName [varPat x1, varPat x2] and_rhs
, methodDef orName [varPat x1, varPat x2] or_rhs
, methodDef xorName [] xor_rhs
, methodDef complementName[] comp_rhs
, methodDef shiftName [] shift_rhs
, methodDef rotateName [] rot_rhs
, methodDef bitSizeName [] bit_rhs
, methodDef isSignedName [] isS_rhs
]
flagsInstance =
hInstance Nothing flagsClass t_ty
[ methodDef orFlagName [varPat x1, varPat x2] or_rhs
]
inv_rhs = qvar autoLib "inEnum"
resv_rhs = qvar autoLib "resEnum"
def_rhs = qvar autoLib "defaultEnum"
vt_elt_rhs = qvar autoLib "vtTypeEnum"
or_rhs = funApp toEnumName [ binOp Add (funApp fromEnumName [x1])
(funApp fromEnumName [x2])]
and_rhs =
hLet (var "flatten")
(lam [patVar "x"]
(hCase (var "x")
[ alt (conPat (mkConName (tdef_name ++ "List__")) [patVar "xs"])
(funApp concatMapName [var "flatten", var "xs"])
, defaultAlt (Just (mkVarName "x")) (hList [var "x"])
]))
(dataCon (mkConName (tdef_name ++ "List__"))
[funApp intersectName [ funApp (mkVarName "flatten") [x1]
, funApp (mkVarName "flatten") [x2]
]])
xor_rhs = funApp prelError
[ stringLit ("Bits.xor{"++qName name++"}: unimplemented") ]
comp_rhs = funApp prelError
[ stringLit ("Bits.complement{"++qName name++"}: unimplemented") ]
shift_rhs = funApp prelError
[ stringLit ("Bits.shift{"++qName name++"}: unimplemented") ]
rot_rhs = funApp prelError
[ stringLit ("Bits.rotate{"++qName name++"}: unimplemented") ]
bit_rhs = funApp prelError
[ stringLit ("Bits.bitSize{"++qName name++"}: unimplemented") ]
isS_rhs = funApp prelError
[ stringLit ("Bits.isSigned{"++qName name++"}: unimplemented") ]
m_rhs
| not optSmartEnums || kind == Unclassified = hCase v (add_m_list (map (enumToInt True) enums))
| otherwise =
case kind of
EnumProgression st 1 -> binOp Add (intLit st)
(funApp LibUtils.enumToInt [v])
EnumProgression st step -> binOp Add (intLit st)
(binOp Mul (intLit step)
(funApp LibUtils.enumToInt [v]))
EnumFlags 0 -> funApp enumToFlag [v]
EnumFlags k -> funApp toIntFlag [intLit k, funApp LibUtils.enumToInt [v]]
Unclassified -> error "MarshallEnum.marshallEnum.m_rhs: the impossible happened"
add_m_list
| withListCon = ((alt (conPat (mkConName (tdef_name ++ "List__")) [patVar "xs"]) rhs) :)
| otherwise = id
where
rhs = funApp orListName [funApp mapListName [varName fromEnumName, var "xs"]]
u_name = qName (prefix unmarshallPrefix name)
u_rhs
| not optSmartEnums || kind == Unclassified = normal_u_rhs
| otherwise =
case kind of
EnumProgression st 1 ->
funApp tagToEnum
[funApp unboxInt
[binOp Sub v (intLit st)]]
EnumProgression st step ->
funApp tagToEnum
[funApp unboxInt
[binOp Div (binOp Sub v (intLit st))
(intLit step)]]
EnumFlags k ->
funApp tagToEnum
[funApp unboxInt
[funApp toIntFlag [intLit k, funApp flagToIntTag [v]]]]
Unclassified -> error "MarshallEnum.marshallEnum.u_rhs: the impossible happened"
normal_u_rhs = hCase v (add_u_list (map intToEnum enums) ++
[defaultAlt Nothing
(giveUp (u_name ++ ": illegal enum value "))])
giveUp msg =funApp prelError [stringLit msg]
add_u_list ls =
case kind of
EnumFlags start -> (ls ++ [alt (patVar "x") (rhsFlg start)])
_ | forceFlag -> (ls ++ [alt (patVar "x") (rhsGen)])
| otherwise -> ls
where
rhsFlg st=
dataCon (mkConName (tdef_name ++ "List__"))
[ funApp mapMaybeName
[ lam [patVar "val"]
(hIf (binOp Eq (binOp And (var "val") (funApp fromIntegralName [var "x"]))
(var "val"))
(just (funApp toEnumName [funApp fromIntegralName [var "val"]]))
nothing)
, funApp pow2Series [intLit (length enums), intLit st]
]
]
rhsGen =
dataCon (mkConName (tdef_name ++ "List__"))
[ funApp mapMaybeName
[ lam [patVar "val"]
(hIf (binOp Eq (binOp And (var "val") (var "x"))
(var "val"))
(just (funApp toEnumName [var "val"]))
nothing)
, hList (map (enumToIntExpr fromIntegralName) enums)
]
]
\end{code}
Helpers:
\begin{code}
enumToInt :: Bool -> EnumValue -> Haskell.CaseAlt
enumToInt long_enum_tags ev@(EnumValue i _) =
alt (patKind (mkConName (mkHaskellTyConName nm))) val
where
patKind
| has_args = \ x -> patRec x []
| otherwise = \ x -> conPat x []
has_args = (idAttributes i) `hasAttributeWithName` "hs_tyarg"
nm = idName i
val = enumToIntExpr coerce ev
coerce = mkQVarName hdirectLib (if long_enum_tags then "toInt32" else "toInt16")
enumToIntExpr :: QualName -> EnumValue -> Haskell.Expr
enumToIntExpr coerce (EnumValue _ v) =
case v of
Left il -> intLit il
Right e -> funApp coerce [coreToHaskellExpr e]
intToEnum :: EnumValue -> Haskell.CaseAlt
intToEnum (EnumValue i (Left v)) = alt (litPat (iLit v)) tag
where
nm = idName i
tag
| has_args = dataCon tag_nm def_vals
| otherwise = dataConst tag_nm
tag_nm = mkConName (mkHaskellTyConName nm)
def_vals =
(\ x ->
case x of
[] -> []
xs -> [lit (LitLit xs)]) $
unwords $
map (\ xs -> '(':xs ++ ")") $
map getStr $
filterAttributes (idAttributes i)
["hs_default"]
getStr (Attribute _ [ParamLit (StringLit s)]) = s
getStr _ = ""
has_args = (idAttributes i) `hasAttributeWithName` "hs_tyarg"
intToEnum eVal = error ("intToEnum: unhandled enum RHS -- " ++ showCore (ppEnumValue eVal))
\end{code}
\begin{code}
genDerivedEnumInstanceFor :: EnumKind -> [EnumValue] -> Bool
genDerivedEnumInstanceFor (EnumProgression 0 1) vs
= not (any (\ x -> idAttributes (enumName x) `hasAttributeWithName` "hs_tyarg") vs)
genDerivedEnumInstanceFor _ _ = False
\end{code}