Translator.hs

   1 module Main(main) where
   2 import GHC
   3 import CoreSyn
   4 import qualified CoreUtils
   5 import qualified Var
   6 import qualified Type
   7 import qualified TyCon
   8 import qualified DataCon
   9 import qualified Maybe
  10 import qualified Module
  11 import qualified Control.Monad.State as State
  12 import Name
  13 import Data.Generics
  14 import NameEnv ( lookupNameEnv )
  15 import HscTypes ( cm_binds, cm_types )
  16 import MonadUtils ( liftIO )
  17 import Outputable ( showSDoc, ppr )
  18 import GHC.Paths ( libdir )
  19 import DynFlags ( defaultDynFlags )
  20 import List ( find )
  21 import qualified List
  22 import qualified Monad
  23
  24 -- The following modules come from the ForSyDe project. They are really
  25 -- internal modules, so ForSyDe.cabal has to be modified prior to installing
  26 -- ForSyDe to get access to these modules.
  27 import qualified ForSyDe.Backend.VHDL.AST as AST
  28 import qualified ForSyDe.Backend.VHDL.Ppr
  29 import qualified ForSyDe.Backend.VHDL.FileIO
  30 import qualified ForSyDe.Backend.Ppr
  31 -- This is needed for rendering the pretty printed VHDL
  32 import Text.PrettyPrint.HughesPJ (render)
  33
  34 main =
  35     do
  36       defaultErrorHandler defaultDynFlags $ do
  37         runGhc (Just libdir) $ do
  38           dflags <- getSessionDynFlags
  39           setSessionDynFlags dflags
  40           --target <- guessTarget "adder.hs" Nothing
  41           --liftIO (print (showSDoc (ppr (target))))
  42           --liftIO $ printTarget target
  43           --setTargets [target]
  44           --load LoadAllTargets
  45           --core <- GHC.compileToCoreSimplified "Adders.hs"
  46           core <- GHC.compileToCoreSimplified "Adders.hs"
  47           --liftIO $ printBinds (cm_binds core)
  48           let binds = Maybe.mapMaybe (findBind (cm_binds core)) ["full_adder", "half_adder"]
  49           liftIO $ printBinds binds
  50           -- Turn bind into VHDL
  51           let vhdl = State.evalState (mkVHDL binds) (VHDLSession 0 [])
  52           liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr vhdl
  53           liftIO $ ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl "../vhdl/vhdl/output.vhdl"
  54           return ()
  55   where
  56     -- Turns the given bind into VHDL
  57     mkVHDL binds = do
  58       -- Add the builtin functions
  59       mapM (uncurry addFunc) builtin_funcs
  60       -- Get the function signatures
  61       funcs <- mapM mkHWFunction binds
  62       -- Add them to the session
  63       mapM (uncurry addFunc) funcs
  64       let entities = map getEntity (snd $ unzip funcs)
  65       -- Create architectures for them
  66       archs <- mapM getArchitecture binds
  67       return $ AST.DesignFile
  68         []
  69         ((map AST.LUEntity entities) ++ (map AST.LUArch archs))
  70
  71 printTarget (Target (TargetFile file (Just x)) obj Nothing) =
  72   print $ show file
  73
  74 printBinds [] = putStr "done\n\n"
  75 printBinds (b:bs) = do
  76   printBind b
  77   putStr "\n"
  78   printBinds bs
  79
  80 printBind (NonRec b expr) = do
  81   putStr "NonRec: "
  82   printBind' (b, expr)
  83
  84 printBind (Rec binds) = do
  85   putStr "Rec: \n"
  86   foldl1 (>>) (map printBind' binds)
  87
  88 printBind' (b, expr) = do
  89   putStr $ getOccString b
  90   putStr $ showSDoc $ ppr expr
  91   putStr "\n"
  92
  93 findBind :: [CoreBind] -> String -> Maybe CoreBind
  94 findBind binds lookfor =
  95   -- This ignores Recs and compares the name of the bind with lookfor,
  96   -- disregarding any namespaces in OccName and extra attributes in Name and
  97   -- Var.
  98   find (\b -> case b of
  99     Rec l -> False
 100     NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
 101   ) binds
 102
 103 getPortMapEntry ::
 104   SignalNameMap  -- The port name to bind to
 105   -> SignalNameMap
 106                             -- The signal or port to bind to it
 107   -> AST.AssocElem          -- The resulting port map entry
 108
 109 -- Accepts a port name and an argument to map to it.
 110 -- Returns the appropriate line for in the port map
 111 getPortMapEntry (Signal portname _) (Signal signame _) =
 112   (Just portname) AST.:=>: (AST.ADName (AST.NSimple signame))
 113 expandExpr ::
 114   [(CoreBndr, SignalNameMap)]
 115                                          -- A list of bindings in effect
 116   -> CoreExpr                            -- The expression to expand
 117   -> VHDLState (
 118        [AST.SigDec],                     -- Needed signal declarations
 119        [AST.ConcSm],                     -- Needed component instantations and
 120                                          -- signal assignments.
 121        [SignalNameMap],       -- The signal names corresponding to
 122                                          -- the expression's arguments
 123        SignalNameMap)         -- The signal names corresponding to
 124                                          -- the expression's result.
 125 expandExpr binds lam@(Lam b expr) = do
 126   -- Generate a new signal to which we will expect this argument to be bound.
 127   signal_name <- uniqueName ("arg_" ++ getOccString b)
 128   -- Find the type of the binder
 129   let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam)
 130   -- Create signal names for the binder
 131   let arg_signal = getPortNameMapForTy ("xxx") arg_ty
 132   -- Create the corresponding signal declarations
 133   let signal_decls = mkSignalsFromMap arg_signal
 134   -- Add the binder to the list of binds
 135   let binds' = (b, arg_signal) : binds
 136   -- Expand the rest of the expression
 137   (signal_decls', statements', arg_signals', res_signal') <- expandExpr binds' expr
 138   -- Properly merge the results
 139   return (signal_decls ++ signal_decls',
 140           statements',
 141           arg_signal : arg_signals',
 142           res_signal')
 143
 144 expandExpr binds (Var id) =
 145   return ([], [], [], Signal signal_id ty)
 146   where
 147     -- Lookup the id in our binds map
 148     Signal signal_id ty = Maybe.fromMaybe
 149       (error $ "Argument " ++ getOccString id ++ "is unknown")
 150       (lookup id binds)
 151
 152 expandExpr binds l@(Let (NonRec b bexpr) expr) = do
 153   (signal_decls, statements, arg_signals, res_signals) <- expandExpr binds bexpr
 154   let binds' = (b, res_signals) : binds
 155   (signal_decls', statements', arg_signals', res_signals') <- expandExpr binds' expr
 156   return (
 157     signal_decls ++ signal_decls',
 158     statements ++ statements',
 159     arg_signals',
 160     res_signals')
 161
 162 expandExpr binds app@(App _ _) = do
 163   let ((Var f), args) = collectArgs app
 164   if isTupleConstructor f
 165     then
 166       expandBuildTupleExpr binds args
 167     else
 168       expandApplicationExpr binds (CoreUtils.exprType app) f args
 169
 170 expandExpr binds expr@(Case (Var v) b _ alts) =
 171   case alts of
 172     [alt] -> expandSingleAltCaseExpr binds v b alt
 173     otherwise -> error $ "Multiple alternative case expression not supported: " ++ (showSDoc $ ppr expr)
 174
 175 expandExpr binds expr@(Case _ b _ _) =
 176   error $ "Case expression with non-variable scrutinee not supported: " ++ (showSDoc $ ppr expr)
 177
 178 expandExpr binds expr =
 179   error $ "Unsupported expression: " ++ (showSDoc $ ppr $ expr)
 180
 181 -- Expands the construction of a tuple into VHDL
 182 expandBuildTupleExpr ::
 183   [(CoreBndr, SignalNameMap)]
 184                                          -- A list of bindings in effect
 185   -> [CoreExpr]                          -- A list of expressions to put in the tuple
 186   -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap], SignalNameMap)
 187                                          -- See expandExpr
 188 expandBuildTupleExpr binds args = do
 189   -- Split the tuple constructor arguments into types and actual values.
 190   let (_, vals) = splitTupleConstructorArgs args
 191   -- Expand each of the values in the tuple
 192   (signals_declss, statementss, arg_signalss, res_signals) <-
 193     (Monad.liftM List.unzip4) $ mapM (expandExpr binds) vals
 194   if any (not . null) arg_signalss
 195     then error "Putting high order functions in tuples not supported"
 196     else
 197       return (
 198         concat signals_declss,
 199         concat statementss,
 200         [],
 201         Tuple res_signals)
 202
 203 -- Expands the most simple case expression that scrutinizes a plain variable
 204 -- and has a single alternative. This simple form currently allows only for
 205 -- unpacking tuple variables.
 206 expandSingleAltCaseExpr ::
 207   [(CoreBndr, SignalNameMap)]
 208                             -- A list of bindings in effect
 209   -> Var.Var                -- The scrutinee
 210   -> CoreBndr               -- The binder to bind the scrutinee to
 211   -> CoreAlt                -- The single alternative
 212   -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap], SignalNameMap)
 213                                          -- See expandExpr
 214
 215 expandSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) =
 216   if not (DataCon.isTupleCon datacon)
 217     then
 218       error $ "Dataconstructors other than tuple constructors not supported in case pattern of alternative: " ++ (showSDoc $ ppr alt)
 219     else
 220       let
 221         -- Lookup the scrutinee (which must be a variable bound to a tuple) in
 222         -- the existing bindings list and get the portname map for each of
 223         -- it's elements.
 224         Tuple tuple_ports = Maybe.fromMaybe
 225           (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
 226           (lookup v binds)
 227         -- TODO include b in the binds list
 228         -- Merge our existing binds with the new binds.
 229         binds' = (zip bind_vars tuple_ports) ++ binds
 230       in
 231         -- Expand the expression with the new binds list
 232         expandExpr binds' expr
 233
 234 expandSingleAltCaseExpr _ _ _ alt =
 235   error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr alt)
 236
 237
 238 -- Expands the application of argument to a function into VHDL
 239 expandApplicationExpr ::
 240   [(CoreBndr, SignalNameMap)]
 241                                          -- A list of bindings in effect
 242   -> Type                                -- The result type of the function call
 243   -> Var.Var                             -- The function to call
 244   -> [CoreExpr]                          -- A list of argumetns to apply to the function
 245   -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap], SignalNameMap)
 246                                          -- See expandExpr
 247 expandApplicationExpr binds ty f args = do
 248   let name = getOccString f
 249   -- Generate a unique name for the application
 250   appname <- uniqueName ("app_" ++ name)
 251   -- Lookup the hwfunction to instantiate
 252   HWFunction vhdl_id inports outport <- getHWFunc name
 253   -- Expand each of the args, so each of them is reduced to output signals
 254   (arg_signal_decls, arg_statements, arg_res_signals) <- expandArgs binds args
 255   -- Bind each of the input ports to the expanded arguments
 256   let inmaps = concat $ zipWith createAssocElems inports arg_res_signals
 257   -- Create signal names for our result
 258   let res_signal = getPortNameMapForTy (appname ++ "_out") ty
 259   -- Create the corresponding signal declarations
 260   let signal_decls = mkSignalsFromMap res_signal
 261   -- Bind each of the output ports to our output signals
 262   let outmaps = mapOutputPorts outport res_signal
 263   -- Instantiate the component
 264   let component = AST.CSISm $ AST.CompInsSm
 265         (AST.unsafeVHDLBasicId appname)
 266         (AST.IUEntity (AST.NSimple vhdl_id))
 267         (AST.PMapAspect (inmaps ++ outmaps))
 268   -- Merge the generated declarations
 269   return (
 270     signal_decls ++ arg_signal_decls,
 271     component : arg_statements,
 272     [], -- We don't take any extra arguments; we don't support higher order functions yet
 273     res_signal)
 274
 275 -- Creates a list of AssocElems (port map lines) that maps the given signals
 276 -- to the given ports.
 277 createAssocElems ::
 278   SignalNameMap      -- The port names to bind to
 279   -> SignalNameMap   -- The signals to bind to it
 280   -> [AST.AssocElem]            -- The resulting port map lines
 281
 282 createAssocElems (Signal port_id _) (Signal signal_id _) =
 283   [(Just port_id) AST.:=>: (AST.ADName (AST.NSimple signal_id))]
 284
 285 createAssocElems (Tuple ports) (Tuple signals) =
 286   concat $ zipWith createAssocElems ports signals
 287
 288 -- Generate a signal declaration for a signal with the given name and the
 289 -- given type and no value. Also returns the id of the signal.
 290 mkSignal :: String -> AST.TypeMark -> (AST.VHDLId, AST.SigDec)
 291 mkSignal name ty =
 292   (id, mkSignalFromId id ty)
 293   where
 294     id = AST.unsafeVHDLBasicId name
 295
 296 mkSignalFromId :: AST.VHDLId -> AST.TypeMark -> AST.SigDec
 297 mkSignalFromId id ty =
 298   AST.SigDec id ty Nothing
 299
 300 -- Generates signal declarations for all the signals in the given map
 301 mkSignalsFromMap ::
 302   SignalNameMap
 303   -> [AST.SigDec]
 304
 305 mkSignalsFromMap (Signal id ty) =
 306   [mkSignalFromId id ty]
 307
 308 mkSignalsFromMap (Tuple signals) =
 309   concat $ map mkSignalsFromMap signals
 310
 311 expandArgs ::
 312   [(CoreBndr, SignalNameMap)] -- A list of bindings in effect
 313   -> [CoreExpr]                          -- The arguments to expand
 314   -> VHDLState ([AST.SigDec], [AST.ConcSm], [SignalNameMap])
 315                                          -- The resulting signal declarations,
 316                                          -- component instantiations and a
 317                                          -- VHDLName for each of the
 318                                          -- expressions passed in.
 319 expandArgs binds (e:exprs) = do
 320   -- Expand the first expression
 321   (signal_decls, statements, arg_signals, res_signal) <- expandExpr binds e
 322   if not (null arg_signals)
 323     then error $ "Passing functions as arguments not supported: " ++ (showSDoc $ ppr e)
 324     else do
 325       (signal_decls', statements', res_signals') <- expandArgs binds exprs
 326       return (
 327         signal_decls ++ signal_decls',
 328         statements ++ statements',
 329         res_signal : res_signals')
 330
 331 expandArgs _ [] = return ([], [], [])
 332
 333 -- Is the given name a (binary) tuple constructor
 334 isTupleConstructor :: Var.Var -> Bool
 335 isTupleConstructor var =
 336   Name.isWiredInName name
 337   && Name.nameModule name == tuple_mod
 338   && (Name.occNameString $ Name.nameOccName name) == "(,)"
 339   where
 340     name = Var.varName var
 341     mod = nameModule name
 342     tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
 343
 344 -- Split arguments into type arguments and value arguments This is probably
 345 -- not really sufficient (not sure if Types can actually occur as value
 346 -- arguments...)
 347 splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
 348 splitTupleConstructorArgs (e:es) =
 349   case e of
 350     Type t     -> (e:tys, vals)
 351     otherwise  -> (tys, e:vals)
 352   where
 353     (tys, vals) = splitTupleConstructorArgs es
 354
 355 splitTupleConstructorArgs [] = ([], [])
 356
 357 mapOutputPorts ::
 358   SignalNameMap      -- The output portnames of the component
 359   -> SignalNameMap   -- The output portnames and/or signals to map these to
 360   -> [AST.AssocElem]            -- The resulting output ports
 361
 362 -- Map the output port of a component to the output port of the containing
 363 -- entity.
 364 mapOutputPorts (Signal portname _) (Signal signalname _) =
 365   [(Just portname) AST.:=>: (AST.ADName (AST.NSimple signalname))]
 366
 367 -- Map matching output ports in the tuple
 368 mapOutputPorts (Tuple ports) (Tuple signals) =
 369   concat (zipWith mapOutputPorts ports signals)
 370
 371 getArchitecture ::
 372   CoreBind                  -- The binder to expand into an architecture
 373   -> VHDLState AST.ArchBody -- The resulting architecture
 374
 375 getArchitecture (Rec _) = error "Recursive binders not supported"
 376
 377 getArchitecture (NonRec var expr) = do
 378   let name = (getOccString var)
 379   HWFunction vhdl_id inports outport <- getHWFunc name
 380   sess <- State.get
 381   (signal_decls, statements, arg_signals, res_signal) <- expandExpr [] expr
 382   let inport_assigns = concat $ zipWith createSignalAssignments arg_signals inports
 383   let outport_assigns = createSignalAssignments outport res_signal
 384   return $ AST.ArchBody
 385     (AST.unsafeVHDLBasicId "structural")
 386     (AST.NSimple vhdl_id)
 387     (map AST.BDISD signal_decls)
 388     (inport_assigns ++ outport_assigns ++ statements)
 389
 390 -- Generate a VHDL entity declaration for the given function
 391 getEntity :: HWFunction -> AST.EntityDec
 392 getEntity (HWFunction vhdl_id inports outport) =
 393   AST.EntityDec vhdl_id ports
 394   where
 395     ports =
 396       (concat $ map (mkIfaceSigDecs AST.In) inports)
 397       ++ mkIfaceSigDecs AST.Out outport
 398
 399 mkIfaceSigDecs ::
 400   AST.Mode                        -- The port's mode (In or Out)
 401   -> SignalNameMap        -- The ports to generate a map for
 402   -> [AST.IfaceSigDec]            -- The resulting ports
 403
 404 mkIfaceSigDecs mode (Signal port_id ty) =
 405   [AST.IfaceSigDec port_id mode ty]
 406
 407 mkIfaceSigDecs mode (Tuple ports) =
 408   concat $ map (mkIfaceSigDecs mode) ports
 409
 410 -- Create concurrent assignments of one map of signals to another. The maps
 411 -- should have a similar form.
 412 createSignalAssignments ::
 413   SignalNameMap         -- The signals to assign to
 414   -> SignalNameMap      -- The signals to assign
 415   -> [AST.ConcSm]                  -- The resulting assignments
 416
 417 -- A simple assignment of one signal to another (greatly complicated because
 418 -- signal assignments can be conditional with multiple conditions in VHDL).
 419 createSignalAssignments (Signal dst _) (Signal src _) =
 420     [AST.CSSASm assign]
 421   where
 422     src_name  = AST.NSimple src
 423     src_expr  = AST.PrimName src_name
 424     src_wform = AST.Wform [AST.WformElem src_expr Nothing]
 425     dst_name  = (AST.NSimple dst)
 426     assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
 427
 428 createSignalAssignments (Tuple dsts) (Tuple srcs) =
 429   concat $ zipWith createSignalAssignments dsts srcs
 430
 431 createSignalAssignments dst src =
 432   error $ "Non matching source and destination: " ++ show dst ++ "\nand\n" ++  show src
 433
 434 data SignalNameMap =
 435   Tuple [SignalNameMap]
 436   | Signal AST.VHDLId AST.TypeMark   -- A signal (or port) of the given (VDHL) type
 437   deriving (Show)
 438
 439 -- Generate a port name map (or multiple for tuple types) in the given direction for
 440 -- each type given.
 441 getPortNameMapForTys :: String -> Int -> [Type] -> [SignalNameMap]
 442 getPortNameMapForTys prefix num [] = []
 443 getPortNameMapForTys prefix num (t:ts) =
 444   (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
 445
 446 getPortNameMapForTy :: String -> Type -> SignalNameMap
 447 getPortNameMapForTy name ty =
 448   if (TyCon.isTupleTyCon tycon) then
 449     -- Expand tuples we find
 450     Tuple (getPortNameMapForTys name 0 args)
 451   else -- Assume it's a type constructor application, ie simple data type
 452     Signal (AST.unsafeVHDLBasicId name) (vhdl_ty ty)
 453   where
 454     (tycon, args) = Type.splitTyConApp ty
 455
 456 data HWFunction = HWFunction { -- A function that is available in hardware
 457   vhdlId    :: AST.VHDLId,
 458   inPorts   :: [SignalNameMap],
 459   outPort   :: SignalNameMap
 460   --entity    :: AST.EntityDec
 461 } deriving (Show)
 462
 463 -- Turns a CoreExpr describing a function into a description of its input and
 464 -- output ports.
 465 mkHWFunction ::
 466   CoreBind                                   -- The core binder to generate the interface for
 467   -> VHDLState (String, HWFunction)          -- The name of the function and its interface
 468
 469 mkHWFunction (NonRec var expr) =
 470     return (name, HWFunction (mkVHDLId name) inports outport)
 471   where
 472     name = getOccString var
 473     ty = CoreUtils.exprType expr
 474     (fargs, res) = Type.splitFunTys ty
 475     args = if length fargs == 1 then fargs else (init fargs)
 476     --state = if length fargs == 1 then () else (last fargs)
 477     inports = case args of
 478       -- Handle a single port specially, to prevent an extra 0 in the name
 479       [port] -> [getPortNameMapForTy "portin" port]
 480       ps     -> getPortNameMapForTys "portin" 0 ps
 481     outport = getPortNameMapForTy "portout" res
 482
 483 mkHWFunction (Rec _) =
 484   error "Recursive binders not supported"
 485
 486 data VHDLSession = VHDLSession {
 487   nameCount :: Int,                      -- A counter that can be used to generate unique names
 488   funcs     :: [(String, HWFunction)]    -- All functions available, indexed by name
 489 } deriving (Show)
 490
 491 type VHDLState = State.State VHDLSession
 492
 493 -- Add the function to the session
 494 addFunc :: String -> HWFunction -> VHDLState ()
 495 addFunc name f = do
 496   fs <- State.gets funcs -- Get the funcs element from the session
 497   State.modify (\x -> x {funcs = (name, f) : fs }) -- Prepend name and f
 498
 499 -- Lookup the function with the given name in the current session. Errors if
 500 -- it was not found.
 501 getHWFunc :: String -> VHDLState HWFunction
 502 getHWFunc name = do
 503   fs <- State.gets funcs -- Get the funcs element from the session
 504   return $ Maybe.fromMaybe
 505     (error $ "Function " ++ name ++ "is unknown? This should not happen!")
 506     (lookup name fs)
 507
 508 -- Makes the given name unique by appending a unique number.
 509 -- This does not do any checking against existing names, so it only guarantees
 510 -- uniqueness with other names generated by uniqueName.
 511 uniqueName :: String -> VHDLState String
 512 uniqueName name = do
 513   count <- State.gets nameCount -- Get the funcs element from the session
 514   State.modify (\s -> s {nameCount = count + 1})
 515   return $ name ++ "_" ++ (show count)
 516
 517 -- Shortcut
 518 mkVHDLId :: String -> AST.VHDLId
 519 mkVHDLId = AST.unsafeVHDLBasicId
 520
 521 builtin_funcs =
 522   [
 523     ("hwxor", HWFunction (mkVHDLId "hwxor") [Signal (mkVHDLId "a") vhdl_bit_ty, Signal (mkVHDLId "b") vhdl_bit_ty] (Signal (mkVHDLId "o") vhdl_bit_ty)),
 524     ("hwand", HWFunction (mkVHDLId "hwand") [Signal (mkVHDLId "a") vhdl_bit_ty, Signal (mkVHDLId "b") vhdl_bit_ty] (Signal (mkVHDLId "o") vhdl_bit_ty)),
 525     ("hwor", HWFunction (mkVHDLId "hwor") [Signal (mkVHDLId "a") vhdl_bit_ty, Signal (mkVHDLId "b") vhdl_bit_ty] (Signal (mkVHDLId "o") vhdl_bit_ty)),
 526     ("hwnot", HWFunction (mkVHDLId "hwnot") [Signal (mkVHDLId "i") vhdl_bit_ty] (Signal (mkVHDLId "o") vhdl_bit_ty))
 527   ]
 528
 529 vhdl_bit_ty :: AST.TypeMark
 530 vhdl_bit_ty = AST.unsafeVHDLBasicId "Bit"
 531
 532 -- Translate a Haskell type to a VHDL type
 533 vhdl_ty :: Type -> AST.TypeMark
 534 vhdl_ty ty = Maybe.fromMaybe
 535   (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
 536   (vhdl_ty_maybe ty)
 537
 538 -- Translate a Haskell type to a VHDL type
 539 vhdl_ty_maybe :: Type -> Maybe AST.TypeMark
 540 vhdl_ty_maybe ty =
 541   case Type.splitTyConApp_maybe ty of
 542     Just (tycon, args) ->
 543       let name = TyCon.tyConName tycon in
 544         -- TODO: Do something more robust than string matching
 545         case getOccString name of
 546           "Bit"      -> Just vhdl_bit_ty
 547           otherwise  -> Nothing
 548     otherwise -> Nothing
 549
 550 -- vim: set ts=8 sw=2 sts=2 expandtab: