Use Data.Accessor for FuncData.

Data.Accessor allows for (automatically) defining accessor functions for
reading and writing record fields. This is a field test to see if it's
useful.

diff --git a/Translator.hs b/Translator.hs
index 2a752a79d34c94cc5ccc4b32cc296b7aaeade5d2..eb4e59f5da01448e8390445e6a511593c626941d 100644 (file)
--- a/Translator.hs
+++ b/Translator.hs
@@ -14,6 +14,7 @@ import qualified Control.Monad.State as State
 import qualified Data.Foldable as Foldable
 import Name
 import qualified Data.Map as Map
+import Data.Accessor
 import Data.Generics
 import NameEnv ( lookupNameEnv )
 import qualified HscTypes
@@ -91,10 +92,10 @@ moduleToVHDL core list = do
       mapM addBuiltIn builtin_funcs
       -- Create entities and architectures for them
       Monad.zipWithM processBind statefuls binds
-      modFuncMap $ Map.map (\fdata -> fdata {flatFunc = fmap nameFlatFunction (flatFunc fdata)})
-      modFuncMap $ Map.mapWithKey (\hsfunc fdata -> fdata {funcEntity = VHDL.createEntity hsfunc fdata})
+      modFuncMap $ Map.map (fdFlatFunc ^: (fmap nameFlatFunction))
+      modFuncMap $ Map.mapWithKey (\hsfunc fdata -> fdEntity ^= (VHDL.createEntity hsfunc fdata) $ fdata)
       funcs <- getFuncMap
-      modFuncMap $ Map.mapWithKey (\hsfunc fdata -> fdata {funcArch = VHDL.createArchitecture funcs hsfunc fdata})
+      modFuncMap $ Map.mapWithKey (\hsfunc fdata -> fdArch ^= (VHDL.createArchitecture funcs hsfunc fdata) $ fdata)
       funcs <- getFuncs
       return $ VHDL.getDesignFiles (map snd funcs)
 

diff --git a/TranslatorTypes.hs b/TranslatorTypes.hs
index 40529ea078d5e46805af27517a070450924c3638..17a2b9cccafbc47dfd6314d0a5d21159a8e9a665 100644 (file)
--- a/TranslatorTypes.hs
+++ b/TranslatorTypes.hs
@@ -2,10 +2,13 @@
 -- Simple module providing some types used by Translator. These are in a
 -- separate module to prevent circular dependencies in Pretty for example.
 --
+{-# LANGUAGE TemplateHaskell #-}
 module TranslatorTypes where
 
 import qualified Control.Monad.State as State
 import qualified Data.Map as Map
+import qualified Data.Accessor.Template
+import Data.Accessor
 
 import qualified HscTypes
 
@@ -22,11 +25,14 @@ type FuncMap  = Map.Map HsFunction FuncData
 
 -- | Some stuff we collect about a function along the way.
 data FuncData = FuncData {
-  flatFunc     :: Maybe FlatFunction,
-  funcEntity   :: Maybe Entity,
-  funcArch     :: Maybe AST.ArchBody
+  fdFlatFunc_ :: Maybe FlatFunction,
+  fdEntity_ :: Maybe Entity,
+  fdArch_ :: Maybe AST.ArchBody
 } deriving (Show)
 
+-- Derive accessors
+$( Data.Accessor.Template.deriveAccessors ''FuncData )
+
 data VHDLSession = VHDLSession {
   coreMod   :: HscTypes.CoreModule, -- The current module
   nameCount :: Int,             -- A counter that can be used to generate unique names
@@ -59,17 +65,17 @@ getHsFuncs = do
 -- | Sets the FlatFunction for the given HsFunction in the current session.
 setFlatFunc :: HsFunction -> FlatFunction -> VHDLState ()
 setFlatFunc hsfunc flatfunc =
-  modFunc (\d -> d { flatFunc = Just flatfunc }) hsfunc
+  modFunc (fdFlatFunc ^= Just flatfunc) hsfunc
 
 -- | Sets the Entity for the given HsFunction in the current session.
 setEntity :: HsFunction -> Entity -> VHDLState ()
 setEntity hsfunc entity =
-  modFunc (\d -> d { funcEntity = Just entity }) hsfunc
+  modFunc (fdEntity ^= Just entity) hsfunc
 
 -- | Sets the Entity for the given HsFunction in the current session.
 setArchitecture :: HsFunction -> AST.ArchBody -> VHDLState ()
 setArchitecture hsfunc arch =
-  modFunc (\d -> d { funcArch = Just arch }) hsfunc
+  modFunc (fdArch ^= Just arch) hsfunc
 
 -- | Modify a function in the map using the given function
 modFunc :: (FuncData -> FuncData) -> HsFunction -> VHDLState ()

diff --git a/VHDL.hs b/VHDL.hs
index f176b9eea6be2c9457280f7e720a678d4fe3f420..418ac181fc95a4c6e0bb43f83410a463de7623b6 100644 (file)
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -11,6 +11,7 @@ import qualified Control.Monad as Monad
 import qualified Control.Arrow as Arrow
 import qualified Data.Traversable as Traversable
 import qualified Data.Monoid as Monoid
+import Data.Accessor
 
 import qualified Type
 import qualified TysWiredIn
@@ -43,9 +44,9 @@ createEntity ::
                     ---  Entity for builtin functions.
 
 createEntity hsfunc fdata = 
-  case flatFunc fdata of
+  case fdata ^. fdFlatFunc of
     -- Skip (builtin) functions without a FlatFunction
-    Nothing -> funcEntity fdata
+    Nothing -> fdata ^. fdEntity
     -- Create an entity for all other functions
     Just flatfunc ->
       let 
@@ -130,9 +131,9 @@ createArchitecture ::
   -> Maybe AST.ArchBody -- ^ The architecture for this function
 
 createArchitecture funcs hsfunc fdata = 
-  case flatFunc fdata of
+  case fdata ^. fdFlatFunc of
     -- Skip (builtin) functions without a FlatFunction
-    Nothing -> funcArch fdata
+    Nothing -> fdata ^. fdArch
     -- Create an architecture for all other functions
     Just flatfunc ->
       let
@@ -218,7 +219,7 @@ mkConcSm funcs sigs (FApp hsfunc args res) num =
         fdata_maybe
     entity = Maybe.fromMaybe
         (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without entity declaration? This should not happen!")
-        (funcEntity fdata)
+        (fdata ^. fdEntity)
     entity_id = ent_id entity
     label = (AST.fromVHDLId entity_id) ++ "_" ++ (show num)
     -- Add a clk port if we have state
@@ -307,7 +308,7 @@ mkAssocElem Nothing _ = Nothing
 -- | Extracts the generated entity id from the given funcdata
 getEntityId :: FuncData -> Maybe AST.VHDLId
 getEntityId fdata =
-  case funcEntity fdata of
+  case fdata ^. fdEntity of
     Nothing -> Nothing
     Just e  -> case ent_decl e of
       Nothing -> Nothing
@@ -318,13 +319,13 @@ getLibraryUnits ::
   -> [AST.LibraryUnit]  -- | The entity, architecture and optional package for the function
 
 getLibraryUnits fdata =
-  case funcEntity fdata of 
+  case fdata ^. fdEntity of 
     Nothing -> []
     Just ent -> 
       case ent_decl ent of
       Nothing -> []
       Just decl ->
-        case funcArch fdata of
+        case fdata ^. fdArch of
           Nothing -> []
           Just arch ->
               [AST.LUEntity decl, AST.LUArch arch]