VHDLTools.hs

   1 module VHDLTools where
   2
   3 -- Standard modules
   4 import qualified Maybe
   5 import qualified Data.Either as Either
   6 import qualified Data.List as List
   7 import qualified Data.Map as Map
   8 import qualified Control.Monad as Monad
   9 import qualified Control.Arrow as Arrow
  10 import qualified Control.Monad.Trans.State as State
  11 import qualified Data.Monoid as Monoid
  12 import Data.Accessor
  13 import Debug.Trace
  14
  15 -- ForSyDe
  16 import qualified ForSyDe.Backend.VHDL.AST as AST
  17
  18 -- GHC API
  19 import CoreSyn
  20 import qualified Name
  21 import qualified OccName
  22 import qualified Var
  23 import qualified Id
  24 import qualified IdInfo
  25 import qualified TyCon
  26 import qualified Type
  27 import qualified DataCon
  28 import qualified CoreSubst
  29
  30 -- Local imports
  31 import VHDLTypes
  32 import CoreTools
  33 import Pretty
  34 import Constants
  35
  36 -----------------------------------------------------------------------------
  37 -- Functions to generate concurrent statements
  38 -----------------------------------------------------------------------------
  39
  40 -- Create an unconditional assignment statement
  41 mkUncondAssign ::
  42   Either CoreBndr AST.VHDLName -- ^ The signal to assign to
  43   -> AST.Expr -- ^ The expression to assign
  44   -> AST.ConcSm -- ^ The resulting concurrent statement
  45 mkUncondAssign dst expr = mkAssign dst Nothing expr
  46
  47 -- Create a conditional assignment statement
  48 mkCondAssign ::
  49   Either CoreBndr AST.VHDLName -- ^ The signal to assign to
  50   -> AST.Expr -- ^ The condition
  51   -> AST.Expr -- ^ The value when true
  52   -> AST.Expr -- ^ The value when false
  53   -> AST.ConcSm -- ^ The resulting concurrent statement
  54 mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
  55
  56 -- Create a conditional or unconditional assignment statement
  57 mkAssign ::
  58   Either CoreBndr AST.VHDLName -> -- ^ The signal to assign to
  59   Maybe (AST.Expr , AST.Expr) -> -- ^ Optionally, the condition to test for
  60                                  -- and the value to assign when true.
  61   AST.Expr -> -- ^ The value to assign when false or no condition
  62   AST.ConcSm -- ^ The resulting concurrent statement
  63 mkAssign dst cond false_expr =
  64   let
  65     -- I'm not 100% how this assignment AST works, but this gets us what we
  66     -- want...
  67     whenelse = case cond of
  68       Just (cond_expr, true_expr) ->
  69         let
  70           true_wform = AST.Wform [AST.WformElem true_expr Nothing]
  71         in
  72           [AST.WhenElse true_wform cond_expr]
  73       Nothing -> []
  74     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
  75     dst_name  = case dst of
  76       Left bndr -> AST.NSimple (varToVHDLId bndr)
  77       Right name -> name
  78     assign    = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
  79   in
  80     AST.CSSASm assign
  81
  82 mkAssocElems ::
  83   [AST.Expr]                    -- | The argument that are applied to function
  84   -> AST.VHDLName               -- | The binder in which to store the result
  85   -> Entity                     -- | The entity to map against.
  86   -> [AST.AssocElem]            -- | The resulting port maps
  87 mkAssocElems args res entity =
  88     -- Create the actual AssocElems
  89     zipWith mkAssocElem ports sigs
  90   where
  91     -- Turn the ports and signals from a map into a flat list. This works,
  92     -- since the maps must have an identical form by definition. TODO: Check
  93     -- the similar form?
  94     arg_ports = ent_args entity
  95     res_port  = ent_res entity
  96     -- Extract the id part from the (id, type) tuple
  97     ports     = map fst (res_port : arg_ports)
  98     -- Translate signal numbers into names
  99     sigs      = (vhdlNameToVHDLExpr res : args)
 100
 101 -- | Create an VHDL port -> signal association
 102 mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
 103 mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal)
 104
 105 -- | Create an VHDL port -> signal association
 106 mkAssocElemIndexed :: AST.VHDLId -> AST.VHDLId -> AST.VHDLId -> AST.AssocElem
 107 mkAssocElemIndexed port signal index = Just port AST.:=>: (AST.ADName (AST.NIndexed (AST.IndexedName
 108                       (AST.NSimple signal) [AST.PrimName $ AST.NSimple index])))
 109
 110 mkComponentInst ::
 111   String -- ^ The portmap label
 112   -> AST.VHDLId -- ^ The entity name
 113   -> [AST.AssocElem] -- ^ The port assignments
 114   -> AST.ConcSm
 115 mkComponentInst label entity_id portassigns = AST.CSISm compins
 116   where
 117     -- We always have a clock port, so no need to map it anywhere but here
 118     clk_port = mkAssocElem (mkVHDLExtId "clk") (idToVHDLExpr $ mkVHDLExtId "clk")
 119     compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port]))
 120
 121 -----------------------------------------------------------------------------
 122 -- Functions to generate VHDL Exprs
 123 -----------------------------------------------------------------------------
 124
 125 -- Turn a variable reference into a AST expression
 126 varToVHDLExpr :: TypeState -> Var.Var -> AST.Expr
 127 varToVHDLExpr ty_state var =
 128   case Id.isDataConWorkId_maybe var of
 129     Just dc -> dataconToVHDLExpr dc
 130     -- This is a dataconstructor.
 131     -- Not a datacon, just another signal. Perhaps we should check for
 132     -- local/global here as well?
 133     -- Sadly so.. tfp decimals are types, not data constructors, but instances
 134     -- should still be translated to integer literals. It is probebly not the
 135     -- best solution to translate them here.
 136     -- FIXME: Find a better solution for translating instances of tfp integers
 137     Nothing ->
 138         let
 139           ty  = Var.varType var
 140           res = case Type.splitTyConApp_maybe ty of
 141                   Just (tycon, args) ->
 142                     case Name.getOccString (TyCon.tyConName tycon) of
 143                       "Dec" -> AST.PrimLit $ (show (fst ( State.runState (tfp_to_int ty) ty_state ) ) )
 144                       otherwise -> AST.PrimName $ AST.NSimple $ varToVHDLId var
 145         in
 146           res
 147
 148
 149 -- Turn a VHDLName into an AST expression
 150 vhdlNameToVHDLExpr = AST.PrimName
 151
 152 -- Turn a VHDL Id into an AST expression
 153 idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
 154
 155 -- Turn a Core expression into an AST expression
 156 exprToVHDLExpr ty_state = (varToVHDLExpr ty_state) . exprToVar
 157
 158 -- Turn a alternative constructor into an AST expression. For
 159 -- dataconstructors, this is only the constructor itself, not any arguments it
 160 -- has. Should not be called with a DEFAULT constructor.
 161 altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
 162 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
 163
 164 altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
 165 altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
 166
 167 -- Turn a datacon (without arguments!) into a VHDL expression.
 168 dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr
 169 dataconToVHDLExpr dc = AST.PrimLit lit
 170   where
 171     tycon = DataCon.dataConTyCon dc
 172     tyname = TyCon.tyConName tycon
 173     dcname = DataCon.dataConName dc
 174     lit = case Name.getOccString tyname of
 175       -- TODO: Do something more robust than string matching
 176       "Bit"      -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
 177       "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
 178
 179 -----------------------------------------------------------------------------
 180 -- Functions dealing with names, variables and ids
 181 -----------------------------------------------------------------------------
 182
 183 -- Creates a VHDL Id from a binder
 184 varToVHDLId ::
 185   CoreSyn.CoreBndr
 186   -> AST.VHDLId
 187 varToVHDLId = mkVHDLExtId . varToString
 188
 189 -- Creates a VHDL Name from a binder
 190 varToVHDLName ::
 191   CoreSyn.CoreBndr
 192   -> AST.VHDLName
 193 varToVHDLName = AST.NSimple . varToVHDLId
 194
 195 -- Extracts the binder name as a String
 196 varToString ::
 197   CoreSyn.CoreBndr
 198   -> String
 199 varToString = OccName.occNameString . Name.nameOccName . Var.varName
 200
 201 -- Get the string version a Var's unique
 202 varToStringUniq :: Var.Var -> String
 203 varToStringUniq = show . Var.varUnique
 204
 205 -- Extracts the string version of the name
 206 nameToString :: Name.Name -> String
 207 nameToString = OccName.occNameString . Name.nameOccName
 208
 209 -- Shortcut for Basic VHDL Ids.
 210 -- Can only contain alphanumerics and underscores. The supplied string must be
 211 -- a valid basic id, otherwise an error value is returned. This function is
 212 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
 213 -- that.
 214 mkVHDLBasicId :: String -> AST.VHDLId
 215 mkVHDLBasicId s =
 216   AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
 217   where
 218     -- Strip invalid characters.
 219     strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
 220     -- Strip leading numbers and underscores
 221     strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
 222     -- Strip multiple adjacent underscores
 223     strip_multiscore = concat . map (\cs ->
 224         case cs of
 225           ('_':_) -> "_"
 226           _ -> cs
 227       ) . List.group
 228
 229 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
 230 -- different characters than basic ids, but can never be used to refer to
 231 -- basic ids.
 232 -- Use extended Ids for any values that are taken from the source file.
 233 mkVHDLExtId :: String -> AST.VHDLId
 234 mkVHDLExtId s =
 235   AST.unsafeVHDLExtId $ strip_invalid s
 236   where
 237     -- Allowed characters, taken from ForSyde's mkVHDLExtId
 238     allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
 239     strip_invalid = filter (`elem` allowed)
 240
 241 -- Create a record field selector that selects the given label from the record
 242 -- stored in the given binder.
 243 mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
 244 mkSelectedName name label =
 245    AST.NSelected $ name AST.:.: (AST.SSimple label)
 246
 247 -- Create an indexed name that selects a given element from a vector.
 248 mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
 249 -- Special case for already indexed names. Just add an index
 250 mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
 251  AST.NIndexed (AST.IndexedName name (indexes++[index]))
 252 -- General case for other names
 253 mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
 254
 255 -----------------------------------------------------------------------------
 256 -- Functions dealing with VHDL types
 257 -----------------------------------------------------------------------------
 258
 259 -- | Maps the string name (OccName) of a type to the corresponding VHDL type,
 260 -- for a few builtin types.
 261 builtin_types =
 262   Map.fromList [
 263     ("Bit", std_logicTM),
 264     ("Bool", booleanTM), -- TysWiredIn.boolTy
 265     ("Dec", integerTM)
 266   ]
 267
 268 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
 269 -- Returns an error value, using the given message, when no type could be
 270 -- created.
 271 vhdl_ty :: String -> Type.Type -> TypeSession AST.TypeMark
 272 vhdl_ty msg ty = do
 273   tm_either <- vhdl_ty_either ty
 274   case tm_either of
 275     Right tm -> return tm
 276     Left err -> error $ msg ++ "\n" ++ err
 277
 278 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
 279 -- Returns either an error message or the resulting type.
 280 vhdl_ty_either :: Type.Type -> TypeSession (Either String AST.TypeMark)
 281 vhdl_ty_either ty = do
 282   typemap <- getA vsTypes
 283   htype_either <- mkHType ty
 284   case htype_either of
 285     -- No errors
 286     Right htype -> do
 287       let builtin_ty = do -- See if this is a tycon and lookup its name
 288             (tycon, args) <- Type.splitTyConApp_maybe ty
 289             let name = Name.getOccString (TyCon.tyConName tycon)
 290             Map.lookup name builtin_types
 291       -- If not a builtin type, try the custom types
 292       let existing_ty = (fmap fst) $ Map.lookup htype typemap
 293       case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
 294         -- Found a type, return it
 295         Just t -> return (Right t)
 296         -- No type yet, try to construct it
 297         Nothing -> do
 298           newty_maybe <- (construct_vhdl_ty ty)
 299           case newty_maybe of
 300             Right (ty_id, ty_def) -> do
 301               -- TODO: Check name uniqueness
 302               modA vsTypes (Map.insert htype (ty_id, ty_def))
 303               modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
 304               return (Right ty_id)
 305             Left err -> return $ Left $
 306               "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
 307               ++ err
 308     -- Error when constructing htype
 309     Left err -> return $ Left err
 310
 311 -- Construct a new VHDL type for the given Haskell type. Returns an error
 312 -- message or the resulting typemark and typedef.
 313 construct_vhdl_ty :: Type.Type -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 314 construct_vhdl_ty ty = do
 315   case Type.splitTyConApp_maybe ty of
 316     Just (tycon, args) -> do
 317       let name = Name.getOccString (TyCon.tyConName tycon)
 318       case name of
 319         "TFVec" -> mk_vector_ty ty
 320         "SizedWord" -> mk_unsigned_ty ty
 321         "SizedInt"  -> mk_signed_ty ty
 322         "RangedWord" -> do
 323           bound <- tfp_to_int (ranged_word_bound_ty ty)
 324           mk_natural_ty 0 bound
 325         -- Create a custom type from this tycon
 326         otherwise -> mk_tycon_ty tycon args
 327     Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
 328
 329 -- | Create VHDL type for a custom tycon
 330 mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 331 mk_tycon_ty tycon args =
 332   case TyCon.tyConDataCons tycon of
 333     -- Not an algebraic type
 334     [] -> return (Left $ "VHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n")
 335     [dc] -> do
 336       let arg_tys = DataCon.dataConRepArgTys dc
 337       -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
 338       -- violation? Or does it only mean not to apply it again to the same
 339       -- subject?
 340       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
 341       elem_tys_either <- mapM vhdl_ty_either real_arg_tys
 342       case Either.partitionEithers elem_tys_either of
 343         -- No errors in element types
 344         ([], elem_tys) -> do
 345           let elems = zipWith AST.ElementDec recordlabels elem_tys
 346           -- For a single construct datatype, build a record with one field for
 347           -- each argument.
 348           -- TODO: Add argument type ids to this, to ensure uniqueness
 349           -- TODO: Special handling for tuples?
 350           let elem_names = concat $ map prettyShow elem_tys
 351           let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
 352           let ty_def = AST.TDR $ AST.RecordTypeDef elems
 353           return $ Right (ty_id, Left ty_def)
 354         -- There were errors in element types
 355         (errors, _) -> return $ Left $
 356           "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
 357           ++ (concat errors)
 358     dcs -> return $ Left $ "VHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
 359   where
 360     -- Create a subst that instantiates all types passed to the tycon
 361     -- TODO: I'm not 100% sure that this is the right way to do this. It seems
 362     -- to work so far, though..
 363     tyvars = TyCon.tyConTyVars tycon
 364     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
 365     -- Generate a bunch of labels for fields of a record
 366     recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
 367
 368 -- | Create a VHDL vector type
 369 mk_vector_ty ::
 370   Type.Type -- ^ The Haskell type of the Vector
 371   -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 372       -- ^ An error message or The typemark created.
 373
 374 mk_vector_ty ty = do
 375   types_map <- getA vsTypes
 376   env <- getA vsHscEnv
 377   let (nvec_l, nvec_el) = Type.splitAppTy ty
 378   let (nvec, leng) = Type.splitAppTy nvec_l
 379   let vec_ty = Type.mkAppTy nvec nvec_el
 380   len <- tfp_to_int (tfvec_len_ty ty)
 381   let el_ty = tfvec_elem ty
 382   el_ty_tm_either <- vhdl_ty_either el_ty
 383   case el_ty_tm_either of
 384     -- Could create element type
 385     Right el_ty_tm -> do
 386       let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
 387       let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
 388       let existing_elem_ty = (fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map
 389       case existing_elem_ty of
 390         Just t -> do
 391           let ty_def = AST.SubtypeIn t (Just range)
 392           return (Right (ty_id, Right ty_def))
 393         Nothing -> do
 394           let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
 395           let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
 396           modA vsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def)))
 397           modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))])
 398           let ty_def = AST.SubtypeIn vec_id (Just range)
 399           return (Right (ty_id, Right ty_def))
 400     -- Could not create element type
 401     Left err -> return $ Left $
 402       "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty  ++ "\n"
 403       ++ err
 404
 405 mk_natural_ty ::
 406   Int -- ^ The minimum bound (> 0)
 407   -> Int -- ^ The maximum bound (> minimum bound)
 408   -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 409       -- ^ An error message or The typemark created.
 410 mk_natural_ty min_bound max_bound = do
 411   let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
 412   let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
 413   let ty_def = AST.SubtypeIn naturalTM (Just range)
 414   return (Right (ty_id, Right ty_def))
 415
 416 mk_unsigned_ty ::
 417   Type.Type -- ^ Haskell type of the unsigned integer
 418   -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 419 mk_unsigned_ty ty = do
 420   size <- tfp_to_int (sized_word_len_ty ty)
 421   let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
 422   let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
 423   let ty_def = AST.SubtypeIn unsignedTM (Just range)
 424   return (Right (ty_id, Right ty_def))
 425
 426 mk_signed_ty ::
 427   Type.Type -- ^ Haskell type of the signed integer
 428   -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 429 mk_signed_ty ty = do
 430   size <- tfp_to_int (sized_int_len_ty ty)
 431   let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
 432   let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
 433   let ty_def = AST.SubtypeIn signedTM (Just range)
 434   return (Right (ty_id, Right ty_def))
 435
 436 -- Finds the field labels for VHDL type generated for the given Core type,
 437 -- which must result in a record type.
 438 getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
 439 getFieldLabels ty = do
 440   -- Ensure that the type is generated (but throw away it's VHDLId)
 441   let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated."
 442   vhdl_ty error_msg ty
 443   -- Get the types map, lookup and unpack the VHDL TypeDef
 444   types <- getA vsTypes
 445   -- Assume the type for which we want labels is really translatable
 446   Right htype <- mkHType ty
 447   case Map.lookup htype types of
 448     Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
 449     _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
 450
 451 mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
 452 mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
 453 mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
 454
 455 mkHType :: Type.Type -> TypeSession (Either String HType)
 456 mkHType ty = do
 457   -- FIXME: Do we really need to do this here again?
 458   let builtin_ty = do -- See if this is a tycon and lookup its name
 459         (tycon, args) <- Type.splitTyConApp_maybe ty
 460         let name = Name.getOccString (TyCon.tyConName tycon)
 461         Map.lookup name builtin_types
 462   case builtin_ty of
 463     Just typ ->
 464       return $ Right $ BuiltinType $ prettyShow typ
 465     Nothing ->
 466       case Type.splitTyConApp_maybe ty of
 467         Just (tycon, args) -> do
 468           let name = Name.getOccString (TyCon.tyConName tycon)
 469           case name of
 470             "TFVec" -> do
 471               let el_ty = tfvec_elem ty
 472               elem_htype_either <- mkHType el_ty
 473               case elem_htype_either of
 474                 -- Could create element type
 475                 Right elem_htype -> do
 476                   env <- getA vsHscEnv
 477                   let norm_ty = normalise_tfp_int env (tfvec_len_ty ty)
 478                   return $ Right $ VecType (OrdType norm_ty) elem_htype
 479                 -- Could not create element type
 480                 Left err -> return $ Left $
 481                   "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty  ++ "\n"
 482                   ++ err
 483             "SizedWord" -> do
 484               len <- tfp_to_int (sized_word_len_ty ty)
 485               return $ Right $ SizedWType len
 486             "SizedInt" -> do
 487               len <- tfp_to_int (sized_word_len_ty ty)
 488               return $ Right $ SizedIType len
 489             "RangedWord" -> do
 490               bound <- tfp_to_int (ranged_word_bound_ty ty)
 491               return $ Right $ RangedWType bound
 492             otherwise -> do
 493               mkTyConHType tycon args
 494         Nothing -> return $ Right $ StdType $ OrdType ty
 495
 496 -- FIXME: Do we really need to do this here again?
 497 mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
 498 mkTyConHType tycon args =
 499   case TyCon.tyConDataCons tycon of
 500     -- Not an algebraic type
 501     [] -> return $ Left $ "VHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"
 502     [dc] -> do
 503       let arg_tys = DataCon.dataConRepArgTys dc
 504       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
 505       elem_htys_either <- mapM mkHType real_arg_tys
 506       case Either.partitionEithers elem_htys_either of
 507         -- No errors in element types
 508         ([], elem_htys) -> do
 509           return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
 510         -- There were errors in element types
 511         (errors, _) -> return $ Left $
 512           "VHDLTools.mkHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
 513           ++ (concat errors)
 514     dcs -> return $ Left $ "VHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
 515   where
 516     tyvars = TyCon.tyConTyVars tycon
 517     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
 518
 519 -- Is the given type representable at runtime?
 520 isReprType :: Type.Type -> TypeSession Bool
 521 isReprType ty = do
 522   ty_either <- vhdl_ty_either ty
 523   return $ case ty_either of
 524     Left _ -> False
 525     Right _ -> True
 526
 527 tfp_to_int :: Type.Type -> TypeSession Int
 528 tfp_to_int ty = do
 529   lens <- getA vsTfpInts
 530   let existing_len = Map.lookup (OrdType ty) lens
 531   case existing_len of
 532     Just len -> return len
 533     Nothing -> do
 534       let new_len = eval_tfp_int ty
 535       modA vsTfpInts (Map.insert (OrdType ty) (new_len))
 536       return new_len