Use data-accessor-transformers package to remove deprecation warnings

[matthijs/master-project/cλash.git] / cλash / CLasH / VHDL / VHDLTools.hs

diff --git a/cλash/CLasH/VHDL/VHDLTools.hs b/cλash/CLasH/VHDL/VHDLTools.hs
index 4b728e858af6f67f0af5c3ee41d3b5719daa8121..db3e13acdf200bd199d2f9d49b617722baf3f18d 100644 (file)
--- a/cλash/CLasH/VHDL/VHDLTools.hs
+++ b/cλash/CLasH/VHDL/VHDLTools.hs
@@ -1,16 +1,17 @@
+{-# LANGUAGE RelaxedPolyRec #-} -- Needed for vhdl_ty_either', for some reason...

 module CLasH.VHDL.VHDLTools where
 
 -- Standard modules
 import qualified Maybe
 import qualified Data.Either as Either
 import qualified Data.List as List
 module CLasH.VHDL.VHDLTools where
 
 -- Standard modules
 import qualified Maybe
 import qualified Data.Either as Either
 import qualified Data.List as List

+import qualified Data.Char as Char

 import qualified Data.Map as Map
 import qualified Control.Monad as Monad
 import qualified Control.Arrow as Arrow
 import qualified Control.Monad.Trans.State as State
 import qualified Data.Monoid as Monoid
 import qualified Data.Map as Map
 import qualified Control.Monad as Monad
 import qualified Control.Arrow as Arrow
 import qualified Control.Monad.Trans.State as State
 import qualified Data.Monoid as Monoid

-import Data.Accessor
-import Data.Accessor.MonadState as MonadState
+import Data.Accessor.Monad.Trans.State as MonadState

 import Debug.Trace
 
 -- ForSyDe
 import Debug.Trace
 
 -- ForSyDe


@@ -27,11 +28,13 @@ import qualified TyCon
 import qualified Type
 import qualified DataCon
 import qualified CoreSubst
 import qualified Type
 import qualified DataCon
 import qualified CoreSubst

+import qualified Outputable

 
 -- Local imports
 import CLasH.VHDL.VHDLTypes
 import CLasH.Translator.TranslatorTypes
 import CLasH.Utils.Core.CoreTools
 
 -- Local imports
 import CLasH.VHDL.VHDLTypes
 import CLasH.Translator.TranslatorTypes
 import CLasH.Utils.Core.CoreTools

+import CLasH.Utils

 import CLasH.Utils.Pretty
 import CLasH.VHDL.Constants
 
 import CLasH.Utils.Pretty
 import CLasH.VHDL.Constants
 


@@ -69,7 +72,7 @@ mkAssign dst cond false_expr =
     whenelse = case cond of
       Just (cond_expr, true_expr) -> 
         let 
     whenelse = case cond of
       Just (cond_expr, true_expr) -> 
         let 

-          true_wform = AST.Wform [AST.WformElem true_expr Nothing] 
+          true_wform = AST.Wform [AST.WformElem true_expr Nothing]

         in
           [AST.WhenElse true_wform cond_expr]
       Nothing -> []
         in
           [AST.WhenElse true_wform cond_expr]
       Nothing -> []


@@ -81,34 +84,52 @@ mkAssign dst cond false_expr =
   in
     AST.CSSASm assign
 
   in
     AST.CSSASm assign
 

+mkAltsAssign ::
+  Either CoreBndr AST.VHDLName            -- ^ The signal to assign to
+  -> [AST.Expr]       -- ^ The conditions
+  -> [AST.Expr]       -- ^ The expressions
+  -> AST.ConcSm   -- ^ The Alt assigns
+mkAltsAssign dst conds exprs
+        | (length conds) /= ((length exprs) - 1) = error $ "\nVHDLTools.mkAltsAssign: conditions expression mismatch"
+        | otherwise =
+  let
+    whenelses   = zipWith mkWhenElse conds exprs
+    false_wform = AST.Wform [AST.WformElem (last exprs) Nothing]
+    dst_name  = case dst of
+      Left bndr -> AST.NSimple (varToVHDLId bndr)
+      Right name -> name
+    assign    = dst_name AST.:<==: (AST.ConWforms whenelses false_wform Nothing)
+  in
+    AST.CSSASm assign
+  where
+    mkWhenElse :: AST.Expr -> AST.Expr -> AST.WhenElse
+    mkWhenElse cond true_expr =
+      let
+        true_wform = AST.Wform [AST.WformElem true_expr Nothing]
+      in
+        AST.WhenElse true_wform cond
+

 mkAssocElems :: 
   [AST.Expr]                    -- ^ The argument that are applied to function
   -> AST.VHDLName               -- ^ The binder in which to store the result
   -> Entity                     -- ^ The entity to map against.
   -> [AST.AssocElem]            -- ^ The resulting port maps
 mkAssocElems args res entity =
 mkAssocElems :: 
   [AST.Expr]                    -- ^ The argument that are applied to function
   -> AST.VHDLName               -- ^ The binder in which to store the result
   -> Entity                     -- ^ The entity to map against.
   -> [AST.AssocElem]            -- ^ The resulting port maps
 mkAssocElems args res entity =

-    -- Create the actual AssocElems
-    zipWith mkAssocElem ports sigs
+    arg_maps ++ (Maybe.maybeToList res_map_maybe)

   where
   where

-    -- Turn the ports and signals from a map into a flat list. This works,
-    -- since the maps must have an identical form by definition. TODO: Check
-    -- the similar form?

     arg_ports = ent_args entity
     arg_ports = ent_args entity

-    res_port  = ent_res entity
-    -- Extract the id part from the (id, type) tuple
-    ports     = map fst (res_port : arg_ports)
-    -- Translate signal numbers into names
-    sigs      = (vhdlNameToVHDLExpr res : args)
+    res_port_maybe = ent_res entity
+    -- Create an expression of res to map against the output port
+    res_expr = vhdlNameToVHDLExpr res
+    -- Map each of the input ports
+    arg_maps = zipWith mkAssocElem (map fst arg_ports) args
+    -- Map the output port, if present
+    res_map_maybe = fmap (\port -> mkAssocElem (fst port) res_expr) res_port_maybe

 
 -- | Create an VHDL port -> signal association
 mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
 mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal) 
 
 
 -- | Create an VHDL port -> signal association
 mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
 mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal) 
 

--- | Create an VHDL port -> signal association
-mkAssocElemIndexed :: AST.VHDLId -> AST.VHDLId -> AST.VHDLId -> AST.AssocElem
-mkAssocElemIndexed port signal index = Just port AST.:=>: (AST.ADName (AST.NIndexed (AST.IndexedName 
-                      (AST.NSimple signal) [AST.PrimName $ AST.NSimple index])))
-

 -- | Create an aggregate signal
 mkAggregateSignal :: [AST.Expr] -> AST.Expr
 mkAggregateSignal x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x)
 -- | Create an aggregate signal
 mkAggregateSignal :: [AST.Expr] -> AST.Expr
 mkAggregateSignal x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x)


@@ -122,7 +143,8 @@ mkComponentInst label entity_id portassigns = AST.CSISm compins
   where
     -- We always have a clock port, so no need to map it anywhere but here
     clk_port = mkAssocElem clockId (idToVHDLExpr clockId)
   where
     -- We always have a clock port, so no need to map it anywhere but here
     clk_port = mkAssocElem clockId (idToVHDLExpr clockId)

-    compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port]))
+    resetn_port = mkAssocElem resetId (idToVHDLExpr resetId)
+    compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port,resetn_port]))

 
 -----------------------------------------------------------------------------
 -- Functions to generate VHDL Exprs
 
 -----------------------------------------------------------------------------
 -- Functions to generate VHDL Exprs


@@ -131,7 +153,7 @@ mkComponentInst label entity_id portassigns = AST.CSISm compins
 varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
 varToVHDLExpr var = do
   case Id.isDataConWorkId_maybe var of
 varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
 varToVHDLExpr var = do
   case Id.isDataConWorkId_maybe var of

-    Just dc -> return $ dataconToVHDLExpr dc
+    Just dc -> dataconToVHDLExpr dc

     -- This is a dataconstructor.
     -- Not a datacon, just another signal. Perhaps we should check for
     -- local/global here as well?
     -- This is a dataconstructor.
     -- Not a datacon, just another signal. Perhaps we should check for
     -- local/global here as well?


@@ -161,23 +183,33 @@ exprToVHDLExpr core = varToVHDLExpr (exprToVar core)
 -- Turn a alternative constructor into an AST expression. For
 -- dataconstructors, this is only the constructor itself, not any arguments it
 -- has. Should not be called with a DEFAULT constructor.
 -- Turn a alternative constructor into an AST expression. For
 -- dataconstructors, this is only the constructor itself, not any arguments it
 -- has. Should not be called with a DEFAULT constructor.

-altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
+altconToVHDLExpr :: CoreSyn.AltCon -> TypeSession AST.Expr

 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
 
 altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
 altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
 
 -- Turn a datacon (without arguments!) into a VHDL expression.
 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
 
 altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
 altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
 
 -- Turn a datacon (without arguments!) into a VHDL expression.

-dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr
-dataconToVHDLExpr dc = AST.PrimLit lit
-  where
-    tycon = DataCon.dataConTyCon dc
-    tyname = TyCon.tyConName tycon
-    dcname = DataCon.dataConName dc
-    lit = case Name.getOccString tyname of
-      -- TODO: Do something more robust than string matching
-      "Bit"      -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
-      "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
+dataconToVHDLExpr :: DataCon.DataCon -> TypeSession AST.Expr
+dataconToVHDLExpr dc = do
+  typemap <- MonadState.get tsTypes
+  htype_either <- mkHTypeEither (DataCon.dataConRepType dc)
+  case htype_either of
+    -- No errors
+    Right htype -> do
+      let dcname = DataCon.dataConName dc
+      case htype of
+        (BuiltinType "Bit") -> return $ AST.PrimLit $ case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
+        (BuiltinType "Bool") -> return $ AST.PrimLit $ case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
+        otherwise -> do
+          let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap
+          case existing_ty of
+            Just ty -> do
+              let lit    = idToVHDLExpr $ mkVHDLExtId $ Name.getOccString dcname
+              return lit
+            Nothing -> error $ "\nVHDLTools.dataconToVHDLExpr: Trying to make value for non-representable DataCon: " ++ pprString dc
+    -- Error when constructing htype
+    Left err -> error err

 
 -----------------------------------------------------------------------------
 -- Functions dealing with names, variables and ids
 
 -----------------------------------------------------------------------------
 -- Functions dealing with names, variables and ids


@@ -187,7 +219,10 @@ dataconToVHDLExpr dc = AST.PrimLit lit
 varToVHDLId ::
   CoreSyn.CoreBndr
   -> AST.VHDLId
 varToVHDLId ::
   CoreSyn.CoreBndr
   -> AST.VHDLId

-varToVHDLId = mkVHDLExtId . varToString
+varToVHDLId var = mkVHDLExtId $ (varToString var ++ varToStringUniq var ++ (show $ lowers $ varToStringUniq var))
+  where
+    lowers :: String -> Int
+    lowers xs = length [x | x <- xs, Char.isLower x]

 
 -- Creates a VHDL Name from a binder
 varToVHDLName ::
 
 -- Creates a VHDL Name from a binder
 varToVHDLName ::


@@ -238,7 +273,7 @@ mkVHDLExtId s =
   AST.unsafeVHDLExtId $ strip_invalid s
   where 
     -- Allowed characters, taken from ForSyde's mkVHDLExtId
   AST.unsafeVHDLExtId $ strip_invalid s
   where 
     -- Allowed characters, taken from ForSyde's mkVHDLExtId

-    allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
+    allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&'()*+,./:;<=>_|!$%@?[]^`{}~-"

     strip_invalid = filter (`elem` allowed)
 
 -- Create a record field selector that selects the given label from the record
     strip_invalid = filter (`elem` allowed)
 
 -- Create a record field selector that selects the given label from the record


@@ -258,204 +293,237 @@ mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
 -----------------------------------------------------------------------------
 -- Functions dealing with VHDL types
 -----------------------------------------------------------------------------
 -----------------------------------------------------------------------------
 -- Functions dealing with VHDL types
 -----------------------------------------------------------------------------

-
--- | Maps the string name (OccName) of a type to the corresponding VHDL type,
--- for a few builtin types.
+builtin_types :: TypeMap

 builtin_types = 
   Map.fromList [
 builtin_types = 
   Map.fromList [

-    ("Bit", Just std_logicTM),
-    ("Bool", Just booleanTM), -- TysWiredIn.boolTy
-    ("Dec", Just integerTM)
+    (BuiltinType "Bit", Just (std_logicTM, Nothing)),
+    (BuiltinType "Bool", Just (booleanTM, Nothing)), -- TysWiredIn.boolTy
+    (BuiltinType "Dec", Just (integerTM, Nothing))

   ]
 
   ]
 

--- 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.
-vhdl_ty :: String -> Type.Type -> TypeSession (Maybe AST.TypeMark)
-vhdl_ty msg ty = do
-  tm_either <- vhdl_ty_either ty
-  case tm_either of
-    Right tm -> return tm
-    Left err -> error $ msg ++ "\n" ++ err
+-- Is the given type representable at runtime?
+isReprType :: Type.Type -> TypeSession Bool
+isReprType ty = do
+  ty_either <- mkHTypeEither ty
+  return $ case ty_either of
+    Left _ -> False
+    Right _ -> True

 
 

--- Translate a Haskell type to a VHDL type, generating a new type if needed.
--- Returns either an error message or the resulting type.
-vhdl_ty_either :: Type.Type -> TypeSession (Either String (Maybe AST.TypeMark))
-vhdl_ty_either ty = do
-  typemap <- getA tsTypes
-  htype_either <- mkHType ty
+mkHType :: (TypedThing t, Outputable.Outputable t) => 
+  String -> t -> TypeSession HType
+mkHType msg ty = do
+  htype_either <- mkHTypeEither ty

   case htype_either of
   case htype_either of

-    -- No errors
-    Right htype -> do
-      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 = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap
-      case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
-        -- Found a type, return it
-        Just t -> return (Right t)
-        -- No type yet, try to construct it
-        Nothing -> do
-          newty_either <- (construct_vhdl_ty ty)
-          case newty_either of
-            Right newty  -> do
-              -- TODO: Check name uniqueness
-              modA tsTypes (Map.insert htype newty)
-              case newty of
-                Just (ty_id, ty_def) -> do
-                  modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
-                  return (Right $ Just ty_id)
-                Nothing -> return $ Right Nothing
-            Left err -> return $ Left $
-              "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
-              ++ err
-    -- Error when constructing htype
-    Left err -> return $ Left err 
-
--- Construct a new VHDL type for the given Haskell type. Returns an error
--- message or the resulting typemark and typedef.
-construct_vhdl_ty :: Type.Type -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
--- State types don't generate VHDL
-construct_vhdl_ty ty | isStateType ty = return $ Right Nothing
-construct_vhdl_ty ty = do
+    Right htype -> return htype
+    Left err -> error $ msg ++ err  
+
+mkHTypeEither :: (TypedThing t, Outputable.Outputable t) => 
+  t -> TypeSession (Either String HType)
+mkHTypeEither tything = do
+  case getType tything of
+    Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither: Typed thing without a type: " ++ pprString tything
+    Just ty -> mkHTypeEither' ty
+
+mkHTypeEither' :: Type.Type -> TypeSession (Either String HType)
+mkHTypeEither' ty | ty_has_free_tyvars ty = return $ Left $ "\nVHDLTools.mkHTypeEither': Cannot create type: type has free type variables: " ++ pprString ty
+                  | isStateType ty = return $ Right StateType
+                  | otherwise = do

   case Type.splitTyConApp_maybe ty of
     Just (tycon, args) -> do
   case Type.splitTyConApp_maybe ty of
     Just (tycon, args) -> do

+      typemap <- MonadState.get tsTypes

       let name = Name.getOccString (TyCon.tyConName tycon)
       let name = Name.getOccString (TyCon.tyConName tycon)

-      case name of
-        "TFVec" -> mk_vector_ty ty
-        "SizedWord" -> mk_unsigned_ty ty
-        "SizedInt"  -> mk_signed_ty ty
-        "RangedWord" -> do 
-          bound <- tfp_to_int (ranged_word_bound_ty ty)
-          mk_natural_ty 0 bound
-        -- Create a custom type from this tycon
-        otherwise -> mk_tycon_ty ty tycon args
-    Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
+      let builtinTyMaybe = Map.lookup (BuiltinType name) typemap  
+      case builtinTyMaybe of
+        (Just x) -> return $ Right $ BuiltinType name
+        Nothing -> do
+          case name of
+                "TFVec" -> do
+                  let el_ty = tfvec_elem ty
+                  elem_htype_either <- mkHTypeEither el_ty
+                  case elem_htype_either of
+                    -- Could create element type
+                    Right elem_htype -> do
+                      len <- tfp_to_int (tfvec_len_ty ty)
+                      return $ Right $ VecType len elem_htype
+                    -- Could not create element type
+                    Left err -> return $ Left $ 
+                      "\nVHDLTools.mkHTypeEither': Can not construct vectortype for elementtype: " ++ pprString el_ty ++ err
+                "SizedWord" -> do
+                  len <- tfp_to_int (sized_word_len_ty ty)
+                  return $ Right $ SizedWType len
+                "SizedInt" -> do
+                  len <- tfp_to_int (sized_word_len_ty ty)
+                  return $ Right $ SizedIType len
+                "RangedWord" -> do
+                  bound <- tfp_to_int (ranged_word_bound_ty ty)
+                  return $ Right $ RangedWType bound
+                otherwise -> do
+                  mkTyConHType tycon args
+    Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither': Do not know what to do with type: " ++ pprString ty

 
 

--- | Create VHDL type for a custom tycon
-mk_tycon_ty :: Type.Type -> TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
-mk_tycon_ty ty tycon args =
+mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
+mkTyConHType tycon args =

   case TyCon.tyConDataCons tycon of
     -- Not an algebraic type
   case TyCon.tyConDataCons tycon of
     -- Not an algebraic type

-    [] -> return (Left $ "VHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n")
+    [] -> return $ Left $ "VHDLTools.mkTyConHType: Only custom algebraic types are supported: " ++ pprString tycon

     [dc] -> do
       let arg_tys = DataCon.dataConRepArgTys dc
     [dc] -> do
       let arg_tys = DataCon.dataConRepArgTys dc

-      -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
-      -- violation? Or does it only mean not to apply it again to the same
-      -- subject?

       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys

-      elem_tys_either <- mapM vhdl_ty_either real_arg_tys
-      case Either.partitionEithers elem_tys_either of
+      let real_arg_tys_nostate = filter (\x -> not (isStateType x)) real_arg_tys
+      elem_htys_either <- mapM mkHTypeEither real_arg_tys_nostate
+      case Either.partitionEithers elem_htys_either of
+        ([], [elem_hty]) -> do
+          return $ Right elem_hty

         -- No errors in element types
         -- No errors in element types

-        ([], elem_tys') -> do
-          -- Throw away all empty members
-          case Maybe.catMaybes elem_tys' of
-            [] -> -- No non-empty members
-              return $ Right Nothing
-            elem_tys -> do
-              let elems = zipWith AST.ElementDec recordlabels elem_tys
-              -- For a single construct datatype, build a record with one field for
-              -- each argument.
-              -- TODO: Add argument type ids to this, to ensure uniqueness
-              -- TODO: Special handling for tuples?
-              let elem_names = concat $ map prettyShow elem_tys
-              let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
-              let ty_def = AST.TDR $ AST.RecordTypeDef elems
-              let tupshow = mkTupleShow elem_tys ty_id
-              modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, tupshow)
-              return $ Right $ Just (ty_id, Left ty_def)
+        ([], elem_htys) -> do
+          return $ Right $ AggrType (nameToString (TyCon.tyConName tycon)) elem_htys

         -- There were errors in element types
         (errors, _) -> return $ Left $
         -- There were errors in element types
         (errors, _) -> return $ Left $

-          "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
+          "\nVHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"

           ++ (concat errors)
           ++ (concat errors)

-    dcs -> return $ Left $ "VHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
+    dcs -> do
+      let arg_tys = concat $ map DataCon.dataConRepArgTys dcs
+      let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
+      case real_arg_tys of
+        [] ->
+          return $ Right $ EnumType (nameToString (TyCon.tyConName tycon)) (map (nameToString . DataCon.dataConName) dcs)
+        xs -> return $ Left $
+          "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n"

   where
   where

-    -- 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)
     tyvars = TyCon.tyConTyVars tycon
     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)

+
+-- 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
+  tm <- vhdlTyMaybe htype
+  return tm
+
+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 = do
+    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 = concat $ map 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

     -- Generate a bunch of labels for fields of a record
     recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
 
 -- | Create a VHDL vector type
     -- 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 (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
+mkVectorTy ::
+  HType -- ^ The Haskell type of the Vector
+  -> TypeSession TypeMapRec

       -- ^ An error message or The typemark created.
 
       -- ^ An error message or The typemark created.
 

-mk_vector_ty ty = do
-  types_map <- getA tsTypes
-  env <- getA tsHscEnv
-  let (nvec_l, nvec_el) = Type.splitAppTy ty
-  let (nvec, leng) = Type.splitAppTy nvec_l
-  let vec_ty = Type.mkAppTy nvec nvec_el
-  len <- tfp_to_int (tfvec_len_ty 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 (Just el_ty_tm) -> do
-      let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
+mkVectorTy (VecType len elHType) = do
+  typesMap <- MonadState.get tsTypes
+  elTyTmMaybe <- vhdlTyMaybe elHType
+  case elTyTmMaybe of
+    (Just elTyTm) -> do
+      let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId elTyTm) ++ "-0_to_" ++ (show len)

       let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
       let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]

-      let existing_elem_ty = (fmap $ fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map
-      case existing_elem_ty of
+      let existing_uvec_ty = (fmap $ fmap fst) $ Map.lookup (UVecType elHType) typesMap
+      case existing_uvec_ty of

         Just (Just t) -> do
           let ty_def = AST.SubtypeIn t (Just range)
         Just (Just t) -> do
           let ty_def = AST.SubtypeIn t (Just range)

-          return (Right $ Just (ty_id, Right ty_def))
+          return (Just (ty_id, Just $ Right ty_def))

         Nothing -> do
         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 tsTypes (Map.insert (StdType $ OrdType vec_ty) (Just (vec_id, (Left vec_def))))
-          modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))])
-          let vecShowFuns = mkVectorShow el_ty_tm vec_id
-          mapM_ (\(id, subprog) -> modA tsTypeFuns $ Map.insert (OrdType vec_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns
+          let vec_id  = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elTyTm)
+          let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] elTyTm
+          MonadState.modify tsTypes (Map.insert (UVecType elHType) (Just (vec_id, (Just $ Left vec_def))))
+          MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Just $ Left vec_def))])
+          let vecShowFuns = mkVectorShow elTyTm vec_id
+          mapM_ (\(id, subprog) -> MonadState.modify tsTypeFuns $ Map.insert (UVecType elHType, id) ((mkVHDLExtId id), subprog)) vecShowFuns

           let ty_def = AST.SubtypeIn vec_id (Just range)
           let ty_def = AST.SubtypeIn vec_id (Just range)

-          return (Right $ Just (ty_id, Right ty_def))
-    -- Empty element type? Empty vector type then. TODO: Does this make sense?
-    -- Probably needs changes in the builtin functions as well...
-    Right Nothing -> return $ Right Nothing
-    -- 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 ::
+          return (Just (ty_id, Just $ Right ty_def))
+    Nothing -> return Nothing
+mkVectorTy htype = error $ "\nVHDLTools.mkVectorTy: Called for HType that is not a VecType: " ++ show htype
+
+mkNaturalTy ::

   Int -- ^ The minimum bound (> 0)
   -> Int -- ^ The maximum bound (> minimum bound)
   Int -- ^ The minimum bound (> 0)
   -> Int -- ^ The maximum bound (> minimum bound)

-  -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
+  -> TypeSession TypeMapRec

       -- ^ An error message or The typemark created.
       -- ^ 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 $ Just (ty_id, Right ty_def))
-
-mk_unsigned_ty ::
-  Type.Type -- ^ Haskell type of the unsigned integer
-  -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
-mk_unsigned_ty ty = do
-  size <- tfp_to_int (sized_word_len_ty ty)
+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 ty_def = AST.SubtypeIn unsignedTM (Just range)
+  return (Just (ty_id, Just $ Right ty_def))
+
+mkUnsignedTy ::
+  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_def = AST.SubtypeIn unsignedTM (Just range)
   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_def = AST.SubtypeIn unsignedTM (Just range)

-  let unsignedshow = mkIntegerShow ty_id
-  modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, unsignedshow)
-  return (Right $ Just (ty_id, Right ty_def))
+  return (Just (ty_id, Just $ Right ty_def))

   
   

-mk_signed_ty ::
-  Type.Type -- ^ Haskell type of the signed integer
-  -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
-mk_signed_ty ty = do
-  size <- tfp_to_int (sized_int_len_ty ty)
+mkSignedTy ::
+  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_def = AST.SubtypeIn signedTM (Just range)
   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_def = AST.SubtypeIn signedTM (Just range)

-  let signedshow = mkIntegerShow ty_id
-  modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, signedshow)
-  return (Right $ Just (ty_id, Right ty_def))
+  return (Just (ty_id, Just $ Right ty_def))

 
 -- Finds the field labels for VHDL type generated for the given Core type,
 -- which must result in a record type.
 
 -- Finds the field labels for VHDL type generated for the given Core type,
 -- which must result in a record type.


@@ -463,95 +531,24 @@ 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." 
 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
+  vhdlTy error_msg ty

   -- Get the types map, lookup and unpack the VHDL TypeDef
   -- Get the types map, lookup and unpack the VHDL TypeDef

-  types <- getA tsTypes
+  types <- MonadState.get tsTypes

   -- Assume the type for which we want labels is really translatable
   -- Assume the type for which we want labels is really translatable

-  Right htype <- mkHType ty
+  htype <- mkHType error_msg ty

   case Map.lookup htype types of
   case Map.lookup htype types of

-    Just (Just (_, Left (AST.TDR (AST.RecordTypeDef elems)))) -> return $ map (\(AST.ElementDec id _) -> id) elems
+    Just (Just (_, Just (Left (AST.TDR (AST.RecordTypeDef elems))))) -> return $ map (\(AST.ElementDec id _) -> id) elems

     Just Nothing -> return [] -- The type is empty
     Just Nothing -> return [] -- The type is empty

-    _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
+    _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show htype)

     
     

-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 <- tfp_to_int (tfvec_len_ty 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
-            "SizedWord" -> do
-              len <- tfp_to_int (sized_word_len_ty ty)
-              return $ Right $ SizedWType len
-            "SizedInt" -> do
-              len <- tfp_to_int (sized_word_len_ty ty)
-              return $ Right $ SizedIType len
-            "RangedWord" -> do
-              bound <- tfp_to_int (ranged_word_bound_ty ty)
-              return $ Right $ RangedWType bound
-            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
-
+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
+mktydecl (ty_id, Just (Right ty_def)) = Just $ AST.PDISD $ AST.SubtypeDec ty_id ty_def

 
 tfp_to_int :: Type.Type -> TypeSession Int
 tfp_to_int ty = do
 
 tfp_to_int :: Type.Type -> TypeSession Int
 tfp_to_int ty = do

-  hscenv <- getA tsHscEnv
+  hscenv <- MonadState.get tsHscEnv

   let norm_ty = normalise_tfp_int hscenv ty
   case Type.splitTyConApp_maybe norm_ty of
     Just (tycon, args) -> do
   let norm_ty = normalise_tfp_int hscenv ty
   case Type.splitTyConApp_maybe norm_ty of
     Just (tycon, args) -> do


@@ -561,21 +558,21 @@ tfp_to_int ty = do
           len <- tfp_to_int' ty
           return len
         otherwise -> do
           len <- tfp_to_int' ty
           return len
         otherwise -> do

-          modA tsTfpInts (Map.insert (OrdType norm_ty) (-1))
+          MonadState.modify tsTfpInts (Map.insert (OrdType norm_ty) (-1))

           return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
     Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
 
 tfp_to_int' :: Type.Type -> TypeSession Int
 tfp_to_int' ty = do
           return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
     Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
 
 tfp_to_int' :: Type.Type -> TypeSession Int
 tfp_to_int' ty = do

-  lens <- getA tsTfpInts
-  hscenv <- getA tsHscEnv
+  lens <- MonadState.get tsTfpInts
+  hscenv <- MonadState.get tsHscEnv

   let norm_ty = normalise_tfp_int hscenv ty
   let existing_len = Map.lookup (OrdType norm_ty) lens
   case existing_len of
     Just len -> return len
     Nothing -> do
       let new_len = eval_tfp_int hscenv ty
   let norm_ty = normalise_tfp_int hscenv ty
   let existing_len = Map.lookup (OrdType norm_ty) lens
   case existing_len of
     Just len -> return len
     Nothing -> do
       let new_len = eval_tfp_int hscenv ty

-      modA tsTfpInts (Map.insert (OrdType norm_ty) (new_len))
+      MonadState.modify tsTfpInts (Map.insert (OrdType norm_ty) (new_len))

       return new_len
       
 mkTupleShow :: 
       return new_len
       
 mkTupleShow :: 


@@ -602,6 +599,17 @@ mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
     recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
     tupSize = length elemTMs
 
     recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
     tupSize = length elemTMs
 

+mkEnumShow ::
+  [AST.VHDLId]
+  -> AST.TypeMark
+  -> AST.SubProgBody
+mkEnumShow elemIds enumTM = AST.SubProgBody showSpec [] [showExpr]
+  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))
+

 mkVectorShow ::
   AST.TypeMark -- ^ elemtype
   -> AST.TypeMark -- ^ vectype
 mkVectorShow ::
   AST.TypeMark -- ^ elemtype
   -> AST.TypeMark -- ^ vectype


@@ -672,26 +680,19 @@ mkVectorShow elemTM vectorTM =
                                genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
                                AST.PrimLit "'>'" )
 
                                genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
                                AST.PrimLit "'>'" )
 

-mkIntegerShow ::
-  AST.TypeMark -- ^ The specific signed
-  -> AST.SubProgBody
-mkIntegerShow signedTM = AST.SubProgBody showSpec [] [showExpr]
-  where
-    signedPar = AST.unsafeVHDLBasicId "sint"
-    showSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
-    showExpr = AST.ReturnSm (Just $
-                AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) 
-                  (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
-      where
-        signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ signedPar)
-

 mkBuiltInShow :: [AST.SubProgBody]
 mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
                 , AST.SubProgBody showBoolSpec [] [showBoolExpr]
 mkBuiltInShow :: [AST.SubProgBody]
 mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
                 , AST.SubProgBody showBoolSpec [] [showBoolExpr]

+                , AST.SubProgBody showSingedSpec [] [showSignedExpr]
+                , AST.SubProgBody showUnsignedSpec [] [showUnsignedExpr]
+                -- , AST.SubProgBody showNaturalSpec [] [showNaturalExpr]

                 ]
   where
                 ]
   where

-    bitPar    = AST.unsafeVHDLBasicId "s"
-    boolPar    = AST.unsafeVHDLBasicId "b"
+    bitPar      = AST.unsafeVHDLBasicId "s"
+    boolPar     = AST.unsafeVHDLBasicId "b"
+    signedPar   = AST.unsafeVHDLBasicId "sint"
+    unsignedPar = AST.unsafeVHDLBasicId "uint"
+    -- naturalPar  = AST.unsafeVHDLBasicId "nat"

     showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
     -- if s = '1' then return "'1'" else return "'0'"
     showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
     showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
     -- if s = '1' then return "'1'" else return "'0'"
     showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")


@@ -704,6 +705,23 @@ mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
                         [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
                         []
                         (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
                         [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
                         []
                         (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])

+    showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
+    showSignedExpr =  AST.ReturnSm (Just $
+                        AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) 
+                        (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
+                      where
+                        signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ signedPar)
+    showUnsignedSpec =  AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM] stringTM
+    showUnsignedExpr =  AST.ReturnSm (Just $
+                          AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) 
+                          (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )
+                        where
+                          unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ unsignedPar)
+    -- showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM
+    -- showNaturalExpr = AST.ReturnSm (Just $
+    --                     AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
+    --                     (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [AST.PrimName $ AST.NSimple $ naturalPar]) Nothing )
+                      

   
 genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
 genExprFCall fName args = 
   
 genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
 genExprFCall fName args = 


@@ -718,7 +736,12 @@ genExprPCall2 entid arg1 arg2 =
 mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec)
 mkSigDec bndr = do
   let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr 
 mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec)
 mkSigDec bndr = do
   let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr 

-  type_mark_maybe <- MonadState.lift tsType $ vhdl_ty error_msg (Var.varType bndr)
+  type_mark_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType bndr)

   case type_mark_maybe of
     Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
     Nothing -> return Nothing
   case type_mark_maybe of
     Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
     Nothing -> return Nothing

+
+-- | Does the given thing have a non-empty type?
+hasNonEmptyType :: (TypedThing t, Outputable.Outputable t) => 
+  t -> TranslatorSession Bool
+hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdlTy "hasNonEmptyType: Non representable type?" thing)