-vhdl_ty :: Type.Type -> ([AST.TypeDec], AST.TypeMark)
-vhdl_ty ty = Maybe.fromMaybe
- (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
- (vhdl_ty_maybe ty)
-
--- Translate a Haskell type to a VHDL type, optionally generating a type
--- declaration for the type.
-vhdl_ty_maybe :: Type.Type -> Maybe ([AST.TypeDec], AST.TypeMark)
-vhdl_ty_maybe ty =
- if Type.coreEqType ty TysWiredIn.boolTy
- then
- Just ([], bool_ty)
- else
- case Type.splitTyConApp_maybe ty of
- Just (tycon, args) ->
- let name = TyCon.tyConName tycon in
- -- TODO: Do something more robust than string matching
- case Name.getOccString name of
- "Bit" -> Just ([], std_logic_ty)
- "FSVec" ->
- let
- [len, el_ty] = args
- -- TODO: Find actual number
- ty_id = mkVHDLId ("vector_" ++ (show len))
- -- TODO: Use el_ty
- range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "16")]
- ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
- ty_dec = AST.TypeDec ty_id ty_def
- in
- Just ([ty_dec], ty_id)
- otherwise -> Nothing
- otherwise -> Nothing
-
--- Shortcut
-mkVHDLId :: String -> AST.VHDLId
-mkVHDLId s =
- AST.unsafeVHDLBasicId $ (strip_multiscore . strip_invalid) s
+vhdl_ty :: Type.Type -> TypeState AST.TypeMark
+vhdl_ty ty = do
+ typemap <- State.get
+ 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
+ -- If not a builtin type, try the custom types
+ let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
+ case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
+ -- Found a type, return it
+ Just t -> return t
+ -- No type yet, try to construct it
+ Nothing -> do
+ let new_ty = do
+ -- Use the Maybe Monad for failing when one of these fails
+ (tycon, args) <- Type.splitTyConApp_maybe ty
+ let name = Name.getOccString (TyCon.tyConName tycon)
+ case name of
+ "FSVec" -> Just $ mk_vector_ty (fsvec_len ty) ty
+ "SizedWord" -> Just $ mk_vector_ty (sized_word_len ty) ty
+ otherwise -> Nothing
+ -- Return new_ty when a new type was successfully created
+ Maybe.fromMaybe
+ (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
+ new_ty
+
+-- | Create a VHDL vector type
+mk_vector_ty ::
+ Int -- ^ The length of the vector
+ -> Type.Type -- ^ The Haskell type to create a VHDL type for
+ -> TypeState AST.TypeMark -- The typemark created.
+
+mk_vector_ty len ty = do
+ -- Assume there is a single type argument
+ let ty_id = mkVHDLExtId $ "vector_" ++ (show len)
+ -- TODO: Use el_ty
+ let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
+ let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
+ let ty_dec = AST.TypeDec ty_id ty_def
+ -- TODO: Check name uniqueness
+ State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
+ return ty_id
+
+
+builtin_types =
+ Map.fromList [
+ ("Bit", std_logic_ty),
+ ("Bool", bool_ty) -- TysWiredIn.boolTy
+ ]
+
+-- Shortcut for
+-- Can only contain alphanumerics and underscores. The supplied string must be
+-- a valid basic id, otherwise an error value is returned. This function is
+-- not meant to be passed identifiers from a source file, use mkVHDLExtId for
+-- that.
+mkVHDLBasicId :: String -> AST.VHDLId
+mkVHDLBasicId s =
+ AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s