Adjusted all the other modules to reflect the new change to CSM

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 }
+          modifyCompState $ \cs -> cs { csOutputIncFile = Just iFile }
-          lift $ withOutputFile cFile $ \hb ->
+          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 :: FilePath -> FilesPassM ()
-    noteFile fp = modify (\fps -> (fp:fps))
+    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 :: String -> FilesPassM ()
-    exec cmd = do lift $ progress $ "Executing command: " ++ cmd
+    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
 

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 ""

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
 

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)

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])

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

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
 

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
+instance CSM (GenParser tok CompState) where
--- CompState:
+  putCompState = setState
-instance MonadState CompState (GenParser tok CompState) where
-  get = getState
-  put = 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
+          modifyCompState $ \st -> st { csLocalNames = (s, (n', nt)) : (csLocalNames st) }
-          put $ 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.

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
+instance CSM (GenParser tok CompState) where
--- CompState:
+  putCompState = setState
-instance MonadState CompState (GenParser tok CompState) where
-  get = getState
-  put = setState
 
 instance Die (GenParser tok st) where
   dieReport (Just m, err) = fail $ packMeta m err

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