VHDL.hs

   1 --
   2 -- Functions to generate VHDL from FlatFunctions
   3 --
   4 module VHDL where
   5
   6 import Data.Traversable
   7 import qualified Maybe
   8
   9 import qualified Type
  10 import qualified Name
  11 import qualified TyCon
  12 import Outputable ( showSDoc, ppr )
  13
  14 import qualified ForSyDe.Backend.VHDL.AST as AST
  15
  16 import VHDLTypes
  17 import FlattenTypes
  18 import TranslatorTypes
  19
  20 -- | Create an entity for a given function
  21 createEntity ::
  22   HsFunction        -- | The function signature
  23   -> FuncData       -- | The function data collected so far
  24   -> FuncData       -- | The modified function data
  25
  26 createEntity hsfunc fdata =
  27   let func = flatFunc fdata in
  28   case func of
  29     -- Skip (builtin) functions without a FlatFunction
  30     Nothing -> fdata
  31     -- Create an entity for all other functions
  32     Just flatfunc ->
  33
  34       let
  35         s       = sigs flatfunc
  36         a       = args flatfunc
  37         r       = res  flatfunc
  38         args'   = map (fmap (mkMap s)) a
  39         res'    = fmap (mkMap s) r
  40         ent_decl' = createEntityAST hsfunc args' res'
  41         entity' = Entity args' res' (Just ent_decl')
  42       in
  43         fdata { entity = Just entity' }
  44   where
  45     mkMap :: Eq id => [(id, SignalInfo)] -> id -> (AST.VHDLId, AST.TypeMark)
  46     mkMap sigmap id =
  47       (mkVHDLId nm, vhdl_ty ty)
  48       where
  49         info = Maybe.fromMaybe
  50           (error $ "Signal not found in the name map? This should not happen!")
  51           (lookup id sigmap)
  52         nm = Maybe.fromMaybe
  53           (error $ "Signal not named? This should not happen!")
  54           (sigName info)
  55         ty = sigTy info
  56
  57 -- | Create the VHDL AST for an entity
  58 createEntityAST ::
  59   HsFunction            -- | The signature of the function we're working with
  60   -> [VHDLSignalMap]    -- | The entity's arguments
  61   -> VHDLSignalMap      -- | The entity's result
  62   -> AST.EntityDec      -- | The entity with the ent_decl filled in as well
  63
  64 createEntityAST hsfunc args res =
  65   AST.EntityDec vhdl_id ports
  66   where
  67     vhdl_id = mkEntityId hsfunc
  68     ports = []
  69
  70 -- | Generate a VHDL entity name for the given hsfunc
  71 mkEntityId hsfunc =
  72   -- TODO: This doesn't work for functions with multiple signatures!
  73   mkVHDLId $ hsFuncName hsfunc
  74
  75 getLibraryUnits ::
  76   (HsFunction, FuncData)      -- | A function from the session
  77   -> [AST.LibraryUnit]        -- | The library units it generates
  78
  79 getLibraryUnits (hsfunc, fdata) =
  80   case entity fdata of
  81     Nothing -> []
  82     Just ent -> case ent_decl ent of
  83       Nothing -> []
  84       Just decl -> [AST.LUEntity decl]
  85
  86 -- | The VHDL Bit type
  87 bit_ty :: AST.TypeMark
  88 bit_ty = AST.unsafeVHDLBasicId "Bit"
  89
  90 -- Translate a Haskell type to a VHDL type
  91 vhdl_ty :: Type.Type -> AST.TypeMark
  92 vhdl_ty ty = Maybe.fromMaybe
  93   (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
  94   (vhdl_ty_maybe ty)
  95
  96 -- Translate a Haskell type to a VHDL type
  97 vhdl_ty_maybe :: Type.Type -> Maybe AST.TypeMark
  98 vhdl_ty_maybe ty =
  99   case Type.splitTyConApp_maybe ty of
 100     Just (tycon, args) ->
 101       let name = TyCon.tyConName tycon in
 102         -- TODO: Do something more robust than string matching
 103         case Name.getOccString name of
 104           "Bit"      -> Just bit_ty
 105           otherwise  -> Nothing
 106     otherwise -> Nothing
 107
 108 -- Shortcut
 109 mkVHDLId :: String -> AST.VHDLId
 110 mkVHDLId = AST.unsafeVHDLBasicId