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 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
 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
       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
       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)
 
       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.
 --
 -- 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
 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
 
 
 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 {
 
 -- | 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)
 
 } 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
 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 =
 -- | 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 =
 
 -- | 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 =
 
 -- | 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 ()
 
 -- | 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 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
 
 import qualified Type
 import qualified TysWiredIn


@@ -43,9 +44,9 @@ createEntity ::
                     ---  Entity for builtin functions.
 
 createEntity hsfunc fdata = 
                     ---  Entity for builtin functions.
 
 createEntity hsfunc fdata = 

-  case flatFunc fdata of
+  case fdata ^. fdFlatFunc of

     -- Skip (builtin) functions without a FlatFunction
     -- Skip (builtin) functions without a FlatFunction

-    Nothing -> funcEntity fdata
+    Nothing -> fdata ^. fdEntity

     -- Create an entity for all other functions
     Just flatfunc ->
       let 
     -- 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 = 
   -> 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
     -- Skip (builtin) functions without a FlatFunction

-    Nothing -> funcArch fdata
+    Nothing -> fdata ^. fdArch

     -- Create an architecture for all other functions
     Just flatfunc ->
       let
     -- 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!")
         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
     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 =
 -- | 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
     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 =
   -> [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 ->
     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]
           Nothing -> []
           Just arch ->
               [AST.LUEntity decl, AST.LUArch arch]