let enum_decs = Maybe.maybeToList enum_dec_maybe
let enum_tys = Maybe.maybeToList enum_ty_maybe
let ty_def = AST.TDR $ AST.RecordTypeDef (enum_decs ++ concat elemss)
- let tupshow = mkTupleShow (enum_tys ++ concat elem_tyss) ty_id
- MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, tupshow)
+ let aggrshow = case enum_field_maybe of
+ Nothing -> mkTupleShow (enum_tys ++ concat elem_tyss) ty_id
+ Just (conLbl, EnumType tycon dcs) -> mkAdtShow conLbl dcs (map (map fst) fieldss) ty_id
+ MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, aggrshow)
return $ Just (ty_id, Just $ Left ty_def)
(EnumType tycon dcs) -> do
- let elems = map mkVHDLExtId dcs
let ty_id = mkVHDLExtId tycon
- let ty_def = AST.TDE $ AST.EnumTypeDef elems
- let enumShow = mkEnumShow elems ty_id
+ let possibilaties = case (length dcs) of 1 -> 1; x -> (x-1)
+ let bitsize = floor (logBase 2 (fromInteger (toInteger possibilaties)))
+ let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show bitsize) (AST.PrimLit "0")]
+ let ty_def = AST.SubtypeIn unsignedTM (Just range)
+ let enumShow = mkEnumShow dcs ty_id
MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, enumShow)
- return $ Just (ty_id, Just $ Left ty_def)
+ return $ Just (ty_id, Just $ Right ty_def)
otherwise -> error $ "\nVHDLTools.mkTyconTy: Called for HType that is neiter a AggrType or EnumType: " ++ show htype
-- | Create a VHDL vector type
mkNaturalTy min_bound max_bound = do
let bitsize = floor (logBase 2 (fromInteger (toInteger max_bound)))
let ty_id = mkVHDLExtId $ "natural_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
- let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit $ show min_bound) (AST.PrimLit $ show bitsize)]
+ let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show bitsize) (AST.PrimLit $ show min_bound)]
let ty_def = AST.SubtypeIn unsignedTM (Just range)
return (Just (ty_id, Just $ Right ty_def))
Int -- ^ Haskell type of the unsigned integer
-> TypeSession TypeMapRec
mkUnsignedTy size = do
- let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
- let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
+ let ty_id = mkVHDLExtId $ "unsigned_" ++ show size
+ let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show (size - 1)) (AST.PrimLit "0")]
let ty_def = AST.SubtypeIn unsignedTM (Just range)
return (Just (ty_id, Just $ Right ty_def))
Int -- ^ Haskell type of the signed integer
-> TypeSession TypeMapRec
mkSignedTy size = do
- let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
- let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
+ let ty_id = mkVHDLExtId $ "signed_" ++ show size
+ let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show (size - 1)) (AST.PrimLit "0")]
let ty_def = AST.SubtypeIn signedTM (Just range)
return (Just (ty_id, Just $ Right ty_def))
getConstructorFieldLabel htype =
error $ "Can't get constructor field label from non-aggregate HType: " ++ show htype
+
+getConstructorIndex ::
+ HType ->
+ String ->
+ Int
+getConstructorIndex (EnumType etype cons) dc = case List.elemIndex dc cons of
+ Just (index) -> index
+ Nothing -> error $ "VHDLTools.getConstructor: constructor: " ++ show dc ++ " is not part of type: " ++ show etype ++ ", which only has constructors: " ++ show cons
+getConstructorIndex htype _ = error $ "Can't get constructor index for non-Enum type: " ++ show htype
+
+
mktydecl :: (AST.VHDLId, Maybe (Either AST.TypeDef AST.SubtypeIn)) -> Maybe AST.PackageDecItem
mytydecl (_, Nothing) = Nothing
mktydecl (ty_id, Just (Left ty_def)) = Just $ AST.PDITD $ AST.TypeDec ty_id ty_def
recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
tupSize = length elemTMs
+mkAdtShow ::
+ String
+ -> [String] -- Constructors
+ -> [[String]] -- Fields for every constructor
+ -> AST.TypeMark
+ -> AST.SubProgBody
+mkAdtShow conLbl conIds elemIdss adtTM = AST.SubProgBody showSpec [] [showExpr]
+ where
+ adtPar = AST.unsafeVHDLBasicId "adt"
+ showSpec = AST.Function showId [AST.IfaceVarDec adtPar adtTM] stringTM
+ showExpr = AST.CaseSm (AST.PrimName $ AST.NSelected $ (AST.NSimple adtPar) AST.:.: (AST.SSimple $ (mkVHDLBasicId conLbl)))
+ [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit $ show x] [AST.ReturnSm (Just $ ((AST.PrimLit $ '"':(conIds!!x)++[' ','"'])) AST.:&: showFields x)] | x <- [0..(length conIds) -1]]
+ showFields i = if (null (elemIdss!!i)) then
+ AST.PrimLit "''"
+ else
+ foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "' '" AST.:&: e2) $
+ map ((genExprFCall showId).
+ AST.PrimName .
+ AST.NSelected .
+ (AST.NSimple adtPar AST.:.:).
+ tupVHDLSuffix)
+ (map mkVHDLBasicId (elemIdss!!i))
+
mkEnumShow ::
- [AST.VHDLId]
+ [String]
-> AST.TypeMark
-> AST.SubProgBody
mkEnumShow elemIds enumTM = AST.SubProgBody showSpec [] [showExpr]
- where
- enumPar = AST.unsafeVHDLBasicId "enum"
+ where
+ enumPar = AST.unsafeVHDLBasicId "enum"
showSpec = AST.Function showId [AST.IfaceVarDec enumPar enumTM] stringTM
- showExpr = AST.ReturnSm (Just $
- AST.PrimLit (show $ tail $ init $ AST.fromVHDLId enumTM))
+ showExpr = AST.CaseSm (AST.PrimName $ AST.NSimple enumPar)
+ [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit $ show x] [AST.ReturnSm (Just $ AST.PrimLit $ '"':(elemIds!!x)++['"'])] | x <- [0..(length elemIds) -1]]
+
mkVectorShow ::
AST.TypeMark -- ^ elemtype