+ _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
+
+mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
+mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
+mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
+
+mkHType :: Type.Type -> TypeSession (Either String HType)
+mkHType ty = do
+ -- FIXME: Do we really need to do this here again?
+ let builtin_ty = do -- See if this is a tycon and lookup its name
+ (tycon, args) <- Type.splitTyConApp_maybe ty
+ let name = Name.getOccString (TyCon.tyConName tycon)
+ Map.lookup name builtin_types
+ case builtin_ty of
+ Just typ ->
+ return $ Right $ BuiltinType $ prettyShow typ
+ Nothing ->
+ case Type.splitTyConApp_maybe ty of
+ Just (tycon, args) -> do
+ let name = Name.getOccString (TyCon.tyConName tycon)
+ case name of
+ "TFVec" -> do
+ let el_ty = tfvec_elem ty
+ elem_htype_either <- mkHType el_ty
+ case elem_htype_either of
+ -- Could create element type
+ Right elem_htype -> do
+ len <- vec_len ty
+ return $ Right $ VecType len elem_htype
+ -- Could not create element type
+ Left err -> return $ Left $
+ "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
+ ++ err
+ otherwise -> do
+ mkTyConHType tycon args
+ Nothing -> return $ Right $ StdType $ OrdType ty
+
+-- FIXME: Do we really need to do this here again?
+mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
+mkTyConHType tycon args =
+ case TyCon.tyConDataCons tycon of
+ -- Not an algebraic type
+ [] -> return $ Left $ "VHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"
+ [dc] -> do
+ let arg_tys = DataCon.dataConRepArgTys dc
+ let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
+ elem_htys_either <- mapM mkHType real_arg_tys
+ case Either.partitionEithers elem_htys_either of
+ -- No errors in element types
+ ([], elem_htys) -> do
+ return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
+ -- There were errors in element types
+ (errors, _) -> return $ Left $
+ "VHDLTools.mkHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
+ ++ (concat errors)
+ dcs -> return $ Left $ "VHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
+ where
+ tyvars = TyCon.tyConTyVars tycon
+ subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
+
+-- Is the given type representable at runtime?
+isReprType :: Type.Type -> TypeSession Bool
+isReprType ty = do
+ ty_either <- vhdl_ty_either ty
+ return $ case ty_either of
+ Left _ -> False
+ Right _ -> True
+
+vec_len :: Type.Type -> TypeSession Int
+vec_len ty = do
+ veclens <- getA vsTfpInts
+ let len_ty = tfvec_len_ty ty
+ let existing_len = Map.lookup (OrdType len_ty) veclens
+ case existing_len of
+ Just len -> return len
+ Nothing -> do
+ let new_len = tfvec_len ty
+ modA vsTfpInts (Map.insert (OrdType len_ty) (new_len))
+ return new_len
\ No newline at end of file