From 6917dbf733c6c9d7ecfe1796133664be26b6b1dc Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Mon, 9 Mar 2009 16:20:05 +0100 Subject: [PATCH] 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. --- Translator.hs | 7 ++++--- TranslatorTypes.hs | 18 ++++++++++++------ VHDL.hs | 17 +++++++++-------- 3 files changed, 25 insertions(+), 17 deletions(-) diff --git a/Translator.hs b/Translator.hs index 2a752a7..eb4e59f 100644 --- 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 40529ea..17a2b9c 100644 --- 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 f176b9e..418ac18 100644 --- 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] -- 2.30.2