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
  46     mkMap sigmap id =
  47       mkVHDLId nm
  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           (name info)
  55
  56 -- | Create the VHDL AST for an entity
  57 createEntityAST ::
  58   HsFunction            -- | The signature of the function we're working with
  59   -> [VHDLSignalMap]    -- | The entity's arguments
  60   -> VHDLSignalMap      -- | The entity's result
  61   -> AST.EntityDec      -- | The entity with the ent_decl filled in as well
  62
  63 createEntityAST hsfunc args res =
  64   AST.EntityDec vhdl_id ports
  65   where
  66     vhdl_id = mkEntityId hsfunc
  67     ports = []
  68
  69 -- | Generate a VHDL entity name for the given hsfunc
  70 mkEntityId hsfunc =
  71   -- TODO: This doesn't work for functions with multiple signatures!
  72   mkVHDLId $ hsFuncName hsfunc
  73
  74 getLibraryUnits ::
  75   (HsFunction, FuncData)      -- | A function from the session
  76   -> [AST.LibraryUnit]        -- | The library units it generates
  77
  78 getLibraryUnits (hsfunc, fdata) =
  79   case entity fdata of
  80     Nothing -> []
  81     Just ent -> case ent_decl ent of
  82       Nothing -> []
  83       Just decl -> [AST.LUEntity decl]
  84
  85 -- | The VHDL Bit type
  86 bit_ty :: AST.TypeMark
  87 bit_ty = AST.unsafeVHDLBasicId "Bit"
  88
  89 -- Translate a Haskell type to a VHDL type
  90 vhdl_ty :: Type.Type -> AST.TypeMark
  91 vhdl_ty ty = Maybe.fromMaybe
  92   (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
  93   (vhdl_ty_maybe ty)
  94
  95 -- Translate a Haskell type to a VHDL type
  96 vhdl_ty_maybe :: Type.Type -> Maybe AST.TypeMark
  97 vhdl_ty_maybe ty =
  98   case Type.splitTyConApp_maybe ty of
  99     Just (tycon, args) ->
 100       let name = TyCon.tyConName tycon in
 101         -- TODO: Do something more robust than string matching
 102         case Name.getOccString name of
 103           "Bit"      -> Just bit_ty
 104           otherwise  -> Nothing
 105     otherwise -> Nothing
 106
 107 -- Shortcut
 108 mkVHDLId :: String -> AST.VHDLId
 109 mkVHDLId = AST.unsafeVHDLBasicId