+ -- Create a subst that instantiates all types passed to the tycon
+ -- TODO: I'm not 100% sure that this is the right way to do this. It seems
+ -- to work so far, though..
+ tyvars = TyCon.tyConTyVars tycon
+ subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
+ -- Generate a bunch of labels for fields of a record
+ recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
+
+-- | Create a VHDL vector type
+mk_vector_ty ::
+ Type.Type -- ^ The Haskell type of the Vector
+ -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+ -- ^ An error message or The typemark created.
+
+mk_vector_ty ty = do
+ types_map <- getA vsTypes
+ let (nvec_l, nvec_el) = Type.splitAppTy ty
+ let (nvec, leng) = Type.splitAppTy nvec_l
+ let vec_ty = Type.mkAppTy nvec nvec_el
+ let len = tfvec_len ty
+ let el_ty = tfvec_elem ty
+ el_ty_tm_either <- vhdl_ty_either el_ty
+ case el_ty_tm_either of
+ -- Could create element type
+ Right el_ty_tm -> do
+ let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
+ let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
+ let existing_elem_ty = (fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map
+ case existing_elem_ty of
+ Just t -> do
+ let ty_def = AST.SubtypeIn t (Just range)
+ return (Right (ty_id, Right ty_def))
+ Nothing -> do
+ let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
+ let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
+ modA vsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def)))
+ modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))])
+ let ty_def = AST.SubtypeIn vec_id (Just range)
+ return (Right (ty_id, Right ty_def))
+ -- Could not create element type
+ Left err -> return $ Left $
+ "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
+ ++ err
+
+mk_natural_ty ::
+ Int -- ^ The minimum bound (> 0)
+ -> Int -- ^ The maximum bound (> minimum bound)
+ -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+ -- ^ An error message or The typemark created.
+mk_natural_ty min_bound max_bound = do
+ let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
+ let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
+ let ty_def = AST.SubtypeIn naturalTM (Just range)
+ return (Right (ty_id, Right ty_def))
+
+-- Finds the field labels for VHDL type generated for the given Core type,
+-- which must result in a record type.
+getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
+getFieldLabels ty = do
+ -- Ensure that the type is generated (but throw away it's VHDLId)
+ let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated."
+ vhdl_ty error_msg ty
+ -- Get the types map, lookup and unpack the VHDL TypeDef
+ types <- getA vsTypes
+ -- Assume the type for which we want labels is really translatable
+ Right htype <- mkHType ty
+ case Map.lookup htype types of
+ Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
+ _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)