TranslatorTypes.hs

   1 --
   2 -- Simple module providing some types used by Translator. These are in a
   3 -- separate module to prevent circular dependencies in Pretty for example.
   4 --
   5 {-# LANGUAGE TemplateHaskell #-}
   6 module TranslatorTypes where
   7
   8 import qualified Control.Monad.State as State
   9 import qualified Data.Map as Map
  10 import qualified Data.Accessor.Template
  11 import Data.Accessor
  12
  13 import qualified HscTypes
  14
  15 import qualified ForSyDe.Backend.VHDL.AST as AST
  16
  17 import FlattenTypes
  18 import VHDLTypes
  19 import HsValueMap
  20
  21
  22 -- | A map from a HsFunction identifier to various stuff we collect about a
  23 --   function along the way.
  24 type FuncMap  = Map.Map HsFunction FuncData
  25
  26 -- | Some stuff we collect about a function along the way.
  27 data FuncData = FuncData {
  28   fdFlatFunc_ :: Maybe FlatFunction,
  29   fdEntity_ :: Maybe Entity,
  30   fdArch_ :: Maybe AST.ArchBody
  31 } deriving (Show)
  32
  33 -- Derive accessors
  34 $( Data.Accessor.Template.deriveAccessors ''FuncData )
  35
  36 data VHDLSession = VHDLSession {
  37   coreMod   :: HscTypes.CoreModule, -- The current module
  38   nameCount :: Int,             -- A counter that can be used to generate unique names
  39   funcs     :: FuncMap          -- A map from HsFunction to FlatFunction, HWFunction, VHDL Entity and Architecture
  40 }
  41
  42 -- | Add the function to the session
  43 addFunc :: HsFunction -> VHDLState ()
  44 addFunc hsfunc =
  45   modFuncMap (Map.insert hsfunc (FuncData Nothing Nothing Nothing))
  46
  47 -- | Find the given function in the current session
  48 getFunc :: HsFunction -> VHDLState (Maybe FuncData)
  49 getFunc hsfunc = do
  50   fs <- State.gets funcs -- Get the funcs element from the session
  51   return $ Map.lookup hsfunc fs
  52
  53 -- | Gets all functions from the current session
  54 getFuncs :: VHDLState [(HsFunction, FuncData)]
  55 getFuncs = do
  56   fs <- State.gets funcs -- Get the funcs element from the session
  57   return $ Map.toList fs
  58
  59 -- | Gets all the functions from the current session
  60 getHsFuncs :: VHDLState [HsFunction]
  61 getHsFuncs = do
  62   fs <- State.gets funcs -- Get the funcs element from the session
  63   return $ Map.keys fs
  64
  65 -- | Sets the FlatFunction for the given HsFunction in the current session.
  66 setFlatFunc :: HsFunction -> FlatFunction -> VHDLState ()
  67 setFlatFunc hsfunc flatfunc =
  68   modFunc (fdFlatFunc ^= Just flatfunc) hsfunc
  69
  70 -- | Sets the Entity for the given HsFunction in the current session.
  71 setEntity :: HsFunction -> Entity -> VHDLState ()
  72 setEntity hsfunc entity =
  73   modFunc (fdEntity ^= Just entity) hsfunc
  74
  75 -- | Sets the Entity for the given HsFunction in the current session.
  76 setArchitecture :: HsFunction -> AST.ArchBody -> VHDLState ()
  77 setArchitecture hsfunc arch =
  78   modFunc (fdArch ^= Just arch) hsfunc
  79
  80 -- | Modify a function in the map using the given function
  81 modFunc :: (FuncData -> FuncData) -> HsFunction -> VHDLState ()
  82 modFunc f hsfunc =
  83   modFuncMap (Map.adjust f hsfunc)
  84
  85 -- | Get the map of functions in the session
  86 getFuncMap :: VHDLState FuncMap
  87 getFuncMap = State.gets funcs
  88
  89 -- | Modify the function map in the session using the given function
  90 modFuncMap :: (FuncMap -> FuncMap) -> VHDLState ()
  91 modFuncMap f = do
  92   fs <- State.gets funcs -- Get the funcs element from the session
  93   let fs' = f fs
  94   State.modify (\x -> x {funcs = fs' })
  95
  96 -- | Apply the given function to all functions in the map, and collect the
  97 --   results. The function is allowed to change the function map in the
  98 --   session, but any new functions added will not be mapped.
  99 modFuncs :: (HsFunction -> FuncData -> VHDLState ()) -> VHDLState ()
 100 modFuncs f = do
 101   hsfuncs <- getHsFuncs
 102   mapM doFunc hsfuncs
 103   return ()
 104   where
 105     doFunc hsfunc = do
 106       fdata_maybe <- getFunc hsfunc
 107       case fdata_maybe of
 108         Nothing -> do return ()
 109         Just fdata -> f hsfunc fdata
 110
 111 getModule :: VHDLState HscTypes.CoreModule
 112 getModule = State.gets coreMod -- Get the coreMod element from the session
 113
 114 type VHDLState = State.State VHDLSession
 115
 116 -- Makes the given name unique by appending a unique number.
 117 -- This does not do any checking against existing names, so it only guarantees
 118 -- uniqueness with other names generated by uniqueName.
 119 uniqueName :: String -> VHDLState String
 120 uniqueName name = do
 121   count <- State.gets nameCount -- Get the funcs element from the session
 122   State.modify (\s -> s {nameCount = count + 1})
 123   return $ name ++ "_" ++ (show count)
 124
 125 -- vim: set ts=8 sw=2 sts=2 expandtab: