diff --git a/Main.hs b/Main.hs index c8626c2..d722070 100644 --- a/Main.hs +++ b/Main.hs @@ -246,7 +246,7 @@ main = do Right initState -> do let operation = case csMode initState of ModePostC -> useOutputOptions (postCAnalyse fn) >> return () - ModeFull -> evalStateT (compileFull fn fileStem) [] + ModeFull -> evalStateT (unwrapFilesPassM $ compileFull fn fileStem) [] mode -> useOutputOptions (compile mode fn) -- Run the compiler. @@ -261,25 +261,32 @@ removeFiles = mapM_ (\file -> catch (removeFile file) doNothing) doNothing :: IOError -> IO () doNothing _ = return () +-- We need a newtype because it has its own instance of Die: +newtype FilesPassM a = FilesPassM (StateT [FilePath] PassM a) + deriving (Monad, MonadIO, CSM, CSMR) + +unwrapFilesPassM :: FilesPassM a -> StateT [FilePath] PassM a +unwrapFilesPassM (FilesPassM x) = x + -- When we die inside the StateT [FilePath] monad, we should delete all the -- temporary files listed in the state, then die in the PassM monad: -- TODO: Not totally sure this technique works if functions inside the PassM -- monad die, but there will only be temp files to clean up if postCAnalyse -- dies -instance Die (StateT [FilePath] PassM) where +instance Die FilesPassM where dieReport err - = do files <- get + = do files <- FilesPassM get -- If removing the files fails, we don't want to die with that -- error; we want the user to see the original error, so ignore -- errors arising from removing the files: - optsPS <- lift $ getCompState + optsPS <- getCompState when (not $ csKeepTemporaries optsPS) $ liftIO $ removeFiles files - lift $ dieReport err + FilesPassM $ dieReport err -compileFull :: String -> Maybe String -> StateT [FilePath] PassM () +compileFull :: String -> Maybe String -> FilesPassM () compileFull inputFile moutputFile - = do optsPS <- lift get + = do optsPS <- getCompState outputFile <- case (csOutputFile optsPS, moutputFile) of -- If the user hasn't given an output file, we guess by -- using a stem (input file minus known extension). @@ -300,15 +307,15 @@ compileFull inputFile moutputFile let cFile = outputFile ++ cExtension hFile = outputFile ++ hExtension iFile = outputFile ++ ".tock.inc" - lift $ modify $ \cs -> cs { csOutputIncFile = Just iFile } - lift $ withOutputFile cFile $ \hb -> + modifyCompState $ \cs -> cs { csOutputIncFile = Just iFile } + withOutputFile cFile $ \hb -> withOutputFile hFile $ \hh -> - compile ModeCompile inputFile ((hb, hh), hFile) + FilesPassM $ lift $ compile ModeCompile inputFile ((hb, hh), hFile) noteFile cFile when (csRunIndent optsPS) $ exec $ "indent " ++ cFile - cs <- lift getCompState + cs <- getCompState case csBackend cs of BackendC -> let sFile = outputFile ++ ".tock.s" @@ -327,7 +334,8 @@ compileFull inputFile moutputFile exec $ cCommand sFile oFile (csCompilerFlags cs) -- Analyse the assembly for stack sizes, and output a -- "post" H file - sizes <- lift $ withOutputFile sizesFile $ \h -> postCAnalyse sFile ((h,intErr),intErr) + sizes <- withOutputFile sizesFile $ \h -> FilesPassM $ lift $ + postCAnalyse sFile ((h,intErr),intErr) when (csHasMain cs) $ do withOutputFile postCFile $ \h -> @@ -345,7 +353,7 @@ compileFull inputFile moutputFile -- For C++, just compile the source file directly into a binary BackendCPPCSP -> - do cs <- lift getCompState + do cs <- getCompState if csHasMain cs then let otherOFiles = [usedFile ++ ".tock.o" | usedFile <- Set.toList $ csUsedFiles cs] @@ -361,7 +369,7 @@ compileFull inputFile moutputFile ++ " with full-compile mode") -- Finally, remove the temporary files: - tempFiles <- get + tempFiles <- FilesPassM get when (not $ csKeepTemporaries cs) $ liftIO $ removeFiles tempFiles @@ -369,8 +377,8 @@ compileFull inputFile moutputFile intErr :: a intErr = error "Internal error involving handles" - noteFile :: Monad m => FilePath -> StateT [FilePath] m () - noteFile fp = modify (\fps -> (fp:fps)) + noteFile :: FilePath -> FilesPassM () + noteFile fp = FilesPassM $ modify (\fps -> (fp:fps)) withOutputFile :: MonadIO m => FilePath -> (Handle -> m a) -> m a withOutputFile path func @@ -379,17 +387,17 @@ compileFull inputFile moutputFile liftIO $ hClose handle return x - exec :: String -> StateT [FilePath] PassM () - exec cmd = do lift $ progress $ "Executing command: " ++ cmd + exec :: String -> FilesPassM () + exec cmd = do progress $ "Executing command: " ++ cmd p <- liftIO $ runCommand cmd exitCode <- liftIO $ waitForProcess p case exitCode of ExitSuccess -> return () ExitFailure n -> dieReport (Nothing, "Command \"" ++ cmd ++ "\" failed: exited with code: " ++ show n) - searchReadFile :: Meta -> String -> StateT [FilePath] PassM String + searchReadFile :: Meta -> String -> FilesPassM String searchReadFile m fn - = do (h, _) <- lift $ searchFile m fn + = do (h, _) <- searchFile m fn liftIO $ hGetContents h -- Don't use hClose because hGetContents is lazy diff --git a/backends/AnalyseAsm.hs b/backends/AnalyseAsm.hs index 7d1a516..e3c427b 100644 --- a/backends/AnalyseAsm.hs +++ b/backends/AnalyseAsm.hs @@ -171,9 +171,6 @@ emptyFI = FunctionInfo { -- | Monad for `AnalyseAsm` operations. type AAM = StateT (Map.Map String FunctionInfo) PassM -instance CSMR AAM where - getCompState = lift getCompState - -- | Collect information about each function that's been defined. collectInfo :: [AsmItem] -> AAM () collectInfo ais = collectInfo' ais "" diff --git a/backends/GenerateCBased.hs b/backends/GenerateCBased.hs index 6faf045..679a4b3 100644 --- a/backends/GenerateCBased.hs +++ b/backends/GenerateCBased.hs @@ -67,9 +67,6 @@ type CGen = ReaderT GenOps CGen' instance Die CGen where dieReport err = lift $ lift $ dieReport err -instance CSMR CGen' where - getCompState = lift getCompState - instance CSMR CGen where getCompState = lift getCompState diff --git a/backends/GenerateCHP.hs b/backends/GenerateCHP.hs index 859a666..3b7fbc5 100644 --- a/backends/GenerateCHP.hs +++ b/backends/GenerateCHP.hs @@ -61,12 +61,6 @@ import Utils -- A handle/string buffer, the current line, and indent stack (push at head) type CGen = StateT (Either [String] Handle, String, [Int]) PassM -instance Die CGen where - dieReport err = lift $ dieReport err - -instance CSMR CGen where - getCompState = lift getCompState - tell :: [String] -> CGen () tell x = do (hb, cur, curIndent:indentStack) <- get let cur' = replace ("\n","\n" ++ replicate curIndent ' ') (cur++concat x) diff --git a/checks/ArrayUsageCheck.hs b/checks/ArrayUsageCheck.hs index 6360fea..f43527f 100644 --- a/checks/ArrayUsageCheck.hs +++ b/checks/ArrayUsageCheck.hs @@ -644,6 +644,9 @@ canonicalise e@(A.FunctionCall m n es) gatherTerms _ e = canonicalise e >>* singleton canonicalise e = return e +instance CSMR (ReaderT CompState (Either String)) where + getCompState = ask + flatten :: A.Expression -> ReaderT CompState (Either String) [FlattenedExp] flatten (A.Literal _ _ (A.IntLiteral _ n)) = return [Const (read n)] flatten e@(A.FunctionCall m fn [lhs, rhs]) diff --git a/common/EvalLiterals.hs b/common/EvalLiterals.hs index eca05fd..9ac21aa 100644 --- a/common/EvalLiterals.hs +++ b/common/EvalLiterals.hs @@ -36,7 +36,7 @@ import Metadata import Traversal import TypeSizes -type EvalM = ErrorT ErrorReport (StateT CompState Identity) +type EvalM = ErrorT ErrorReport (State CompState) instance Die EvalM where dieReport = throwError @@ -90,7 +90,7 @@ evalByte m s -- | Run an evaluator operation. runEvaluator :: CompState -> EvalM OccValue -> Either ErrorReport OccValue runEvaluator ps func - = runIdentity (evalStateT (runErrorT func) ps) + = evalState (runErrorT func) ps -- | Evaluate a simple literal expression. evalSimpleExpression :: A.Expression -> EvalM OccValue diff --git a/common/OccamEDSL.hs b/common/OccamEDSL.hs index df5fbb4..6535c52 100644 --- a/common/OccamEDSL.hs +++ b/common/OccamEDSL.hs @@ -140,6 +140,9 @@ instance MonadState s (ExpInpT (State s)) where instance CSMR (ExpInpT (State CompState)) where getCompState = get +instance CSM (ExpInpT (State CompState)) where + putCompState = put + type O a = ExpInpT (State CompState) a type Occ a = O a diff --git a/frontends/ParseOccam.hs b/frontends/ParseOccam.hs index 4eeb04e..bc7fbfb 100644 --- a/frontends/ParseOccam.hs +++ b/frontends/ParseOccam.hs @@ -48,15 +48,12 @@ type OccParser = GenParser Token CompState instance CSMR (GenParser tok CompState) where getCompState = getState --- We can expose only part of the state to make it look like we are only using --- CompState: -instance MonadState CompState (GenParser tok CompState) where - get = getState - put = setState +instance CSM (GenParser tok CompState) where + putCompState = setState -- The other part of the state is actually the built-up list of warnings: instance Warn (GenParser tok CompState) where - warnReport w@(_,t,_) = modify $ + warnReport w@(_,t,_) = modifyCompState $ \cs -> cs { csWarnings = if t `Set.member` csEnabledWarnings cs then csWarnings cs ++ [w] @@ -394,7 +391,7 @@ intersperseP (f:fs) sep --{{{ name scoping findName :: A.Name -> NameType -> OccParser A.Name findName thisN thisNT - = do st <- get + = do st <- getCompState (origN, origNT) <- case lookup (A.nameName thisN) (csLocalNames st) of Nothing -> dieP (A.nameMeta thisN) $ "name " ++ A.nameName thisN ++ " not defined" @@ -420,16 +417,15 @@ scopeIn n@(A.Name m s) nt specType am (munged, ns) A.ndPlacement = A.Unplaced } defineName n' nd - st <- get - put $ st { csLocalNames = (s, (n', nt)) : (csLocalNames st) } + modifyCompState $ \st -> st { csLocalNames = (s, (n', nt)) : (csLocalNames st) } return n' scopeOut :: A.Name -> OccParser () scopeOut n@(A.Name m _) - = do st <- get + = do st <- getCompState case csLocalNames st of ((_, (old, _)):rest) - | old == n -> put $ st { csLocalNames = rest } + | old == n -> putCompState $ st { csLocalNames = rest } | otherwise -> dieInternal (Just m, "scoping out not in order; " ++ " tried to scope out: " ++ A.nameName n ++ " but found: " ++ A.nameName old) _ -> dieInternal (Just m, "scoping out name when stack is empty") @@ -1497,11 +1493,11 @@ pragma = do m <- getPosition >>* sourcePosToMeta handleShared m = do vars <- sepBy1 identifier sComma mapM_ (\var -> - do st <- get + do st <- getCompState A.Name _ n <- case lookup var (csLocalNames st) of Nothing -> dieP m $ "name " ++ var ++ " not defined" Just def -> return $ fst def - modify $ \st -> st {csNameAttr = Map.insertWith Set.union + modifyCompState $ \st -> st {csNameAttr = Map.insertWith Set.union n (Set.singleton NameShared) (csNameAttr st)}) vars return Nothing @@ -1509,11 +1505,11 @@ pragma = do m <- getPosition >>* sourcePosToMeta handlePermitAliases m = do vars <- sepBy1 identifier sComma mapM_ (\var -> - do st <- get + do st <- getCompState A.Name _ n <- case lookup var (csLocalNames st) of Nothing -> dieP m $ "name " ++ var ++ " not defined" Just def -> return $ fst def - modify $ \st -> st {csNameAttr = Map.insertWith Set.union + modifyCompState $ \st -> st {csNameAttr = Map.insertWith Set.union n (Set.singleton NameAliasesPermitted) (csNameAttr st)}) vars return Nothing @@ -1521,16 +1517,16 @@ pragma = do m <- getPosition >>* sourcePosToMeta = do case metaFile m of Nothing -> dieP m "PRAGMA TOCKSIZES in undeterminable file" Just f -> let (f', _) = splitExtension f in - modify $ \cs -> cs { csExtraSizes = (f' ++ pragStr) : csExtraSizes cs } + modifyCompState $ \cs -> cs { csExtraSizes = (f' ++ pragStr) : csExtraSizes cs } return Nothing handleInclude m [pragStr] = do case metaFile m of Nothing -> dieP m "PRAGMA TOCKINCLUDE in undeterminable file" Just f -> let (f', _) = splitExtension f in - modify $ \cs -> cs { csExtraIncludes = (f' ++ pragStr) : csExtraIncludes cs } + modifyCompState $ \cs -> cs { csExtraIncludes = (f' ++ pragStr) : csExtraIncludes cs } return Nothing handleNativeLink m [pragStr] - = do modify $ \cs -> cs { csCompilerLinkFlags = csCompilerLinkFlags cs ++ " " ++ pragStr} + = do modifyCompState $ \cs -> cs { csCompilerLinkFlags = csCompilerLinkFlags cs ++ " " ++ pragStr} return Nothing handleExternal isCExternal m @@ -1557,7 +1553,7 @@ pragma = do m <- getPosition >>* sourcePosToMeta return (n, FunctionName, origN, fs, A.Function m (A.PlainSpec, A.PlainRec) ts fs Nothing) let ext = if isCExternal then ExternalOldStyle else ExternalOccam - modify $ \st -> st + modifyCompState $ \st -> st { csExternals = (A.nameName n, ext) : csExternals st } return $ Just (A.Specification m origN sp, nt, (Just n, A.NameExternal)) @@ -2028,7 +2024,7 @@ topLevelItem -- Stash the current locals so that we can either restore them -- when we get back to the file we included this one from, or -- pull the TLP name from them at the end. - modify $ (\ps -> ps { csMainLocals = csLocalNames ps }) + modifyCompState $ (\ps -> ps { csMainLocals = csLocalNames ps }) return $ A.Several m [] -- | A source file is a series of nested specifications. diff --git a/frontends/ParseRain.hs b/frontends/ParseRain.hs index ecd8fc0..6d86ffa 100644 --- a/frontends/ParseRain.hs +++ b/frontends/ParseRain.hs @@ -43,11 +43,8 @@ type RainParser = GenParser L.Token RainState instance CSMR (GenParser tok CompState) where getCompState = getState --- We can expose only part of the state to make it look like we are only using --- CompState: -instance MonadState CompState (GenParser tok CompState) where - get = getState - put = setState +instance CSM (GenParser tok CompState) where + putCompState = setState instance Die (GenParser tok st) where dieReport (Just m, err) = fail $ packMeta m err diff --git a/frontends/RainTypes.hs b/frontends/RainTypes.hs index 61dbb98..5634d0b 100644 --- a/frontends/RainTypes.hs +++ b/frontends/RainTypes.hs @@ -71,12 +71,6 @@ type RainTypeCheckOn2 a b = forall t. type RainTypeCheck a = a -> RainTypeM () -instance Die RainTypeM where - dieReport = lift . dieReport - -instance CSMR RainTypeM where - getCompState = lift getCompState - lookupMapElseMutVar :: A.TypeRequirements -> UnifyIndex -> RainTypeM (TypeExp A.Type) lookupMapElseMutVar reqs k = do st <- get