+
+-- Translate a Haskell type to a VHDL type, generating a new type if needed.
+-- Returns an error value, using the given message, when no type could be
+-- created. Returns Nothing when the type is valid, but empty.
+vhdlTy :: (TypedThing t, Outputable.Outputable t) =>
+ String -> t -> TypeSession (Maybe AST.TypeMark)
+vhdlTy msg ty = do
+ htype <- mkHType msg ty
+ vhdlTyMaybe htype
+
+vhdlTyMaybe :: HType -> TypeSession (Maybe AST.TypeMark)
+vhdlTyMaybe htype = do
+ typemap <- MonadState.get tsTypes
+ -- If not a builtin type, try the custom types
+ let existing_ty = Map.lookup htype typemap
+ case existing_ty of
+ -- Found a type, return it
+ Just (Just (t, _)) -> return $ Just t
+ Just (Nothing) -> return Nothing
+ -- No type yet, try to construct it
+ Nothing -> do
+ newty <- (construct_vhdl_ty htype)
+ MonadState.modify tsTypes (Map.insert htype newty)
+ case newty of
+ Just (ty_id, ty_def) -> do
+ MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
+ return $ Just ty_id
+ Nothing -> return Nothing
+
+-- Construct a new VHDL type for the given Haskell type. Returns an error
+-- message or the resulting typemark and typedef.
+construct_vhdl_ty :: HType -> TypeSession TypeMapRec
+-- State types don't generate VHDL
+construct_vhdl_ty htype =
+ case htype of
+ StateType -> return Nothing
+ (SizedWType w) -> mkUnsignedTy w
+ (SizedIType i) -> mkSignedTy i
+ (RangedWType u) -> mkNaturalTy 0 u
+ (VecType n e) -> mkVectorTy (VecType n e)
+ -- Create a custom type from this tycon
+ otherwise -> mkTyconTy htype
+
+-- | Create VHDL type for a custom tycon
+mkTyconTy :: HType -> TypeSession TypeMapRec
+mkTyconTy htype =
+ case htype of
+ (AggrType tycon args) -> do
+ elemTysMaybe <- mapM vhdlTyMaybe args
+ case Maybe.catMaybes elemTysMaybe of
+ [] -> -- No non-empty members
+ return Nothing
+ elem_tys -> do
+ let elems = zipWith AST.ElementDec recordlabels elem_tys
+ let elem_names = concatMap prettyShow elem_tys
+ let ty_id = mkVHDLExtId $ tycon ++ elem_names
+ let ty_def = AST.TDR $ AST.RecordTypeDef elems
+ let tupshow = mkTupleShow elem_tys ty_id
+ MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, tupshow)
+ 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
+ MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, enumShow)
+ return $ Just (ty_id, Just $ Left ty_def)
+ otherwise -> error $ "\nVHDLTools.mkTyconTy: Called for HType that is neiter a AggrType or EnumType: " ++ show htype
+ where