From: Christiaan Baaij Date: Tue, 10 Nov 2009 16:42:18 +0000 (+0100) Subject: Use data-accessor-transformers package to remove deprecation warnings X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=eab16fafe7a623b5ea669023b91ddee4b1983526;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Use data-accessor-transformers package to remove deprecation warnings --- diff --git "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" index c9e2f80..936a4ec 100644 --- "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" +++ "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" @@ -16,7 +16,7 @@ import qualified Control.Monad.Trans.Writer as Writer import qualified "transformers" Control.Monad.Trans as Trans import qualified Data.Map as Map import Data.Accessor -import Data.Accessor.MonadState as MonadState +import Data.Accessor.Monad.Trans.State as MonadState -- GHC API import CoreSyn diff --git "a/c\316\273ash/CLasH/Translator.hs" "b/c\316\273ash/CLasH/Translator.hs" index 8884506..16158d2 100644 --- "a/c\316\273ash/CLasH/Translator.hs" +++ "b/c\316\273ash/CLasH/Translator.hs" @@ -10,7 +10,7 @@ import qualified Monad import qualified System.FilePath as FilePath import qualified Control.Monad.Trans.State as State import Text.PrettyPrint.HughesPJ (render) -import Data.Accessor +import Data.Accessor.Monad.Trans.State import qualified Data.Map as Map import Debug.Trace diff --git "a/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" "b/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" index 2591e66..56c5c75 100644 --- "a/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" +++ "b/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" @@ -9,7 +9,7 @@ module CLasH.Translator.TranslatorTypes where import qualified Control.Monad.Trans.State as State import qualified Data.Map as Map import qualified Data.Accessor.Template -import Data.Accessor +import qualified Data.Accessor.Monad.Trans.State as MonadState -- GHC API import qualified GHC @@ -109,23 +109,23 @@ type TranslatorSession = State.State TranslatorState -- module(s)? isTopLevelBinder :: CoreSyn.CoreBndr -> TranslatorSession Bool isTopLevelBinder bndr = do - bindings <- getA tsBindings + bindings <- MonadState.get tsBindings return $ Map.member bndr bindings -- Finds the value of a global binding, if available getGlobalBind :: CoreSyn.CoreBndr -> TranslatorSession (Maybe CoreSyn.CoreExpr) getGlobalBind bndr = do - bindings <- getA tsBindings + bindings <- MonadState.get tsBindings return $ Map.lookup bndr bindings -- Adds a new global binding with the given value addGlobalBind :: CoreSyn.CoreBndr -> CoreSyn.CoreExpr -> TranslatorSession () -addGlobalBind bndr expr = modA tsBindings (Map.insert bndr expr) +addGlobalBind bndr expr = MonadState.modify tsBindings (Map.insert bndr expr) -- Returns a list of all global binders getGlobalBinders :: TranslatorSession [CoreSyn.CoreBndr] getGlobalBinders = do - bindings <- getA tsBindings + bindings <- MonadState.get tsBindings return $ Map.keys bindings -- vim: set ts=8 sw=2 sts=2 expandtab: diff --git "a/c\316\273ash/CLasH/Utils.hs" "b/c\316\273ash/CLasH/Utils.hs" index 94da854..51c6ebf 100644 --- "a/c\316\273ash/CLasH/Utils.hs" +++ "b/c\316\273ash/CLasH/Utils.hs" @@ -3,6 +3,7 @@ module CLasH.Utils where -- Standard Imports import qualified Maybe import Data.Accessor +import Data.Accessor.Monad.Trans.State as MonadState import qualified Data.Map as Map import qualified Control.Monad as Monad import qualified Control.Monad.Trans.State as State @@ -19,14 +20,14 @@ makeCached :: (Monad m, Ord k) => -> State.StateT s m v -- ^ The resulting value, from the cache or freshly -- computed. makeCached key accessor create = do - cache <- getA accessor + cache <- MonadState.get accessor case Map.lookup key cache of -- Found in cache, just return Just value -> return value -- Not found, compute it and put it in the cache Nothing -> do value <- create - modA accessor (Map.insert key value) + MonadState.modify accessor (Map.insert key value) return value unzipM :: (Monad m) => diff --git "a/c\316\273ash/CLasH/Utils/Core/BinderTools.hs" "b/c\316\273ash/CLasH/Utils/Core/BinderTools.hs" index a072c45..ef69474 100644 --- "a/c\316\273ash/CLasH/Utils/Core/BinderTools.hs" +++ "b/c\316\273ash/CLasH/Utils/Core/BinderTools.hs" @@ -4,7 +4,7 @@ module CLasH.Utils.Core.BinderTools where -- Standard modules -import Data.Accessor.MonadState as MonadState +import Data.Accessor.Monad.Trans.State as MonadState -- GHC API import CoreSyn @@ -22,16 +22,14 @@ import qualified VarSet import qualified HscTypes -- Local imports -import Data.Accessor -import Data.Accessor.MonadState as MonadState import CLasH.Translator.TranslatorTypes -- Create a new Unique mkUnique :: TranslatorSession Unique.Unique mkUnique = do - us <- getA tsUniqSupply + us <- MonadState.get tsUniqSupply let (us', us'') = UniqSupply.splitUniqSupply us - putA tsUniqSupply us' + MonadState.set tsUniqSupply us' return $ UniqSupply.uniqFromSupply us'' -- Create a new internal var with the given name and type. A Unique is diff --git "a/c\316\273ash/CLasH/VHDL.hs" "b/c\316\273ash/CLasH/VHDL.hs" index 762a0f4..21671ad 100644 --- "a/c\316\273ash/CLasH/VHDL.hs" +++ "b/c\316\273ash/CLasH/VHDL.hs" @@ -11,7 +11,7 @@ import qualified Control.Arrow as Arrow import qualified Control.Monad.Trans.State as State import qualified Data.Monoid as Monoid import Data.Accessor -import Data.Accessor.MonadState as MonadState +import Data.Accessor.Monad.Trans.State as MonadState import Debug.Trace -- ForSyDe @@ -82,9 +82,9 @@ createTypesPackage :: -- ^ The id and content of the types package createTypesPackage = do - tyfuns <- getA (tsType .> tsTypeFuns) + tyfuns <- MonadState.get (tsType .> tsTypeFuns) let tyfun_decls = mkBuiltInShow ++ (map snd $ Map.elems tyfuns) - ty_decls_maybes <- getA (tsType .> tsTypeDecls) + ty_decls_maybes <- MonadState.get (tsType .> tsTypeDecls) let ty_decls = Maybe.catMaybes ty_decls_maybes let subProgSpecs = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec) tyfun_decls let type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs) diff --git "a/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs" index 3c738a0..4b24b57 100644 --- "a/c\316\273ash/CLasH/VHDL/Generate.hs" +++ "b/c\316\273ash/CLasH/VHDL/Generate.hs" @@ -6,8 +6,7 @@ import qualified Data.Map as Map import qualified Control.Monad as Monad import qualified Maybe import qualified Data.Either as Either -import Data.Accessor -import Data.Accessor.MonadState as MonadState +import Data.Accessor.Monad.Trans.State as MonadState import Debug.Trace -- ForSyDe @@ -50,9 +49,9 @@ getEntity fname = Utils.makeCached fname tsEntities $ do args' <- catMaybesM $ mapM mkMap args -- TODO: Handle Nothing res' <- mkMap res - count <- getA tsEntityCounter + count <- MonadState.get tsEntityCounter let vhdl_id = mkVHDLBasicId $ varToString fname ++ "Component_" ++ show count - putA tsEntityCounter (count + 1) + MonadState.set tsEntityCounter (count + 1) let ent_decl = createEntityAST vhdl_id args' res' let signature = Entity vhdl_id args' res' ent_decl return signature @@ -130,7 +129,7 @@ getArchitecture fname = Utils.makeCached fname tsArchitectures $ do let (in_state_maybes, out_state_maybes) = unzip state_vars let (statementss, used_entitiess) = unzip sms -- Get initial state, if it's there - initSmap <- getA tsInitStates + initSmap <- MonadState.get tsInitStates let init_state = Map.lookup fname initSmap -- Create a state proc, if needed (state_proc, resbndr) <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes, init_state) of @@ -340,7 +339,7 @@ genLitArgs :: (dst -> func -> [Literal.Literal] -> TranslatorSession [AST.ConcSm]) -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.ConcSm]) genLitArgs wrap dst func args = do - hscenv <- MonadState.lift tsType $ getA tsHscEnv + hscenv <- MonadState.lift tsType $ MonadState.get tsHscEnv let (exprargs, []) = Either.partitionEithers args -- FIXME: Check if we were passed an CoreSyn.App let litargs = concat (map (getLiterals hscenv) exprargs) @@ -1092,7 +1091,7 @@ vectorFunId el_ty fname = do -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in -- the VHDLState or something. let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM) - typefuns <- getA tsTypeFuns + typefuns <- MonadState.get tsTypeFuns el_htype <- mkHType error_msg el_ty case Map.lookup (UVecType el_htype, fname) typefuns of -- Function already generated, just return it @@ -1102,7 +1101,7 @@ vectorFunId el_ty fname = do let functions = genUnconsVectorFuns elemTM vectorTM case lookup fname functions of Just body -> do - modA tsTypeFuns $ Map.insert (UVecType el_htype, fname) (function_id, (fst body)) + MonadState.modify tsTypeFuns $ Map.insert (UVecType el_htype, fname) (function_id, (fst body)) mapM_ (vectorFunId el_ty) (snd body) return function_id Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname diff --git "a/c\316\273ash/CLasH/VHDL/Testbench.hs" "b/c\316\273ash/CLasH/VHDL/Testbench.hs" index 399846d..89988f5 100644 --- "a/c\316\273ash/CLasH/VHDL/Testbench.hs" +++ "b/c\316\273ash/CLasH/VHDL/Testbench.hs" @@ -7,8 +7,7 @@ module CLasH.VHDL.Testbench where import qualified Control.Monad as Monad import qualified Maybe import qualified Data.Map as Map -import Data.Accessor -import qualified Data.Accessor.MonadState as MonadState +import qualified Data.Accessor.Monad.Trans.State as MonadState -- ForSyDe import qualified Language.VHDL.AST as AST @@ -42,9 +41,9 @@ createTestbench mCycles cores stimuli top = do -- testbench has no outputs and no inputs. bndr <- mkInternalVar "testbench" TysWiredIn.unitTy let entity = createTestbenchEntity bndr - modA tsEntities (Map.insert bndr entity) + MonadState.modify tsEntities (Map.insert bndr entity) arch <- createTestbenchArch mCycles stimuli' top entity - modA tsArchitectures (Map.insert bndr arch) + MonadState.modify tsArchitectures (Map.insert bndr arch) return bndr createTestbenchEntity :: diff --git "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" index 546fc12..db3e13a 100644 --- "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" +++ "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" @@ -11,8 +11,7 @@ import qualified Control.Monad as Monad import qualified Control.Arrow as Arrow import qualified Control.Monad.Trans.State as State import qualified Data.Monoid as Monoid -import Data.Accessor -import Data.Accessor.MonadState as MonadState +import Data.Accessor.Monad.Trans.State as MonadState import Debug.Trace -- ForSyDe @@ -193,7 +192,7 @@ altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative shou -- Turn a datacon (without arguments!) into a VHDL expression. dataconToVHDLExpr :: DataCon.DataCon -> TypeSession AST.Expr dataconToVHDLExpr dc = do - typemap <- getA tsTypes + typemap <- MonadState.get tsTypes htype_either <- mkHTypeEither (DataCon.dataConRepType dc) case htype_either of -- No errors @@ -331,7 +330,7 @@ mkHTypeEither' ty | ty_has_free_tyvars ty = return $ Left $ "\nVHDLTools.mkHType | otherwise = do case Type.splitTyConApp_maybe ty of Just (tycon, args) -> do - typemap <- getA tsTypes + typemap <- MonadState.get tsTypes let name = Name.getOccString (TyCon.tyConName tycon) let builtinTyMaybe = Map.lookup (BuiltinType name) typemap case builtinTyMaybe of @@ -406,7 +405,7 @@ vhdlTy msg ty = do vhdlTyMaybe :: HType -> TypeSession (Maybe AST.TypeMark) vhdlTyMaybe htype = do - typemap <- getA tsTypes + typemap <- MonadState.get tsTypes -- If not a builtin type, try the custom types let existing_ty = Map.lookup htype typemap case existing_ty of @@ -416,10 +415,10 @@ vhdlTyMaybe htype = do -- No type yet, try to construct it Nothing -> do newty <- (construct_vhdl_ty htype) - modA tsTypes (Map.insert htype newty) + MonadState.modify tsTypes (Map.insert htype newty) case newty of Just (ty_id, ty_def) -> do - modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)]) + MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)]) return $ Just ty_id Nothing -> return Nothing @@ -452,14 +451,14 @@ mkTyconTy htype = let ty_id = mkVHDLExtId $ tycon ++ elem_names let ty_def = AST.TDR $ AST.RecordTypeDef elems let tupshow = mkTupleShow elem_tys ty_id - modA tsTypeFuns $ Map.insert (htype, showIdString) (showId, tupshow) + MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, tupshow) return $ Just (ty_id, Just $ Left ty_def) (EnumType tycon dcs) -> do let elems = map mkVHDLExtId dcs let ty_id = mkVHDLExtId tycon let ty_def = AST.TDE $ AST.EnumTypeDef elems let enumShow = mkEnumShow elems ty_id - modA tsTypeFuns $ Map.insert (htype, showIdString) (showId, enumShow) + MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, enumShow) return $ Just (ty_id, Just $ Left ty_def) otherwise -> error $ "\nVHDLTools.mkTyconTy: Called for HType that is neiter a AggrType or EnumType: " ++ show htype where @@ -473,7 +472,7 @@ mkVectorTy :: -- ^ An error message or The typemark created. mkVectorTy (VecType len elHType) = do - typesMap <- getA tsTypes + typesMap <- MonadState.get tsTypes elTyTmMaybe <- vhdlTyMaybe elHType case elTyTmMaybe of (Just elTyTm) -> do @@ -487,10 +486,10 @@ mkVectorTy (VecType len elHType) = do Nothing -> do let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elTyTm) let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] elTyTm - modA tsTypes (Map.insert (UVecType elHType) (Just (vec_id, (Just $ Left vec_def)))) - modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Just $ Left vec_def))]) + MonadState.modify tsTypes (Map.insert (UVecType elHType) (Just (vec_id, (Just $ Left vec_def)))) + MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Just $ Left vec_def))]) let vecShowFuns = mkVectorShow elTyTm vec_id - mapM_ (\(id, subprog) -> modA tsTypeFuns $ Map.insert (UVecType elHType, id) ((mkVHDLExtId id), subprog)) vecShowFuns + mapM_ (\(id, subprog) -> MonadState.modify tsTypeFuns $ Map.insert (UVecType elHType, id) ((mkVHDLExtId id), subprog)) vecShowFuns let ty_def = AST.SubtypeIn vec_id (Just range) return (Just (ty_id, Just $ Right ty_def)) Nothing -> return Nothing @@ -534,7 +533,7 @@ getFieldLabels ty = do let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated." vhdlTy error_msg ty -- Get the types map, lookup and unpack the VHDL TypeDef - types <- getA tsTypes + types <- MonadState.get tsTypes -- Assume the type for which we want labels is really translatable htype <- mkHType error_msg ty case Map.lookup htype types of @@ -549,7 +548,7 @@ mktydecl (ty_id, Just (Right ty_def)) = Just $ AST.PDISD $ AST.SubtypeDec ty_id tfp_to_int :: Type.Type -> TypeSession Int tfp_to_int ty = do - hscenv <- getA tsHscEnv + hscenv <- MonadState.get tsHscEnv let norm_ty = normalise_tfp_int hscenv ty case Type.splitTyConApp_maybe norm_ty of Just (tycon, args) -> do @@ -559,21 +558,21 @@ tfp_to_int ty = do len <- tfp_to_int' ty return len otherwise -> do - modA tsTfpInts (Map.insert (OrdType norm_ty) (-1)) + MonadState.modify tsTfpInts (Map.insert (OrdType norm_ty) (-1)) return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty)) Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty)) tfp_to_int' :: Type.Type -> TypeSession Int tfp_to_int' ty = do - lens <- getA tsTfpInts - hscenv <- getA tsHscEnv + lens <- MonadState.get tsTfpInts + hscenv <- MonadState.get tsHscEnv let norm_ty = normalise_tfp_int hscenv ty let existing_len = Map.lookup (OrdType norm_ty) lens case existing_len of Just len -> return len Nothing -> do let new_len = eval_tfp_int hscenv ty - modA tsTfpInts (Map.insert (OrdType norm_ty) (new_len)) + MonadState.modify tsTfpInts (Map.insert (OrdType norm_ty) (new_len)) return new_len mkTupleShow :: diff --git "a/c\316\273ash/clash.cabal" "b/c\316\273ash/clash.cabal" index 1797f28..6a262e8 100644 --- "a/c\316\273ash/clash.cabal" +++ "b/c\316\273ash/clash.cabal" @@ -20,7 +20,8 @@ Library build-depends: ghc >= 6.11, pretty, vhdl > 0.1, haskell98, syb, data-accessor, containers, base >= 4, transformers, filepath, template-haskell, data-accessor-template, - prettyclass, directory, th-lift-ng, tfp, tfvec + data-accessor-transformers, prettyclass, directory, + th-lift-ng, tfp, tfvec exposed-modules: CLasH.HardwareTypes CLasH.Translator