suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Neil Brown 2009-04-17 17:40:00 +00:00
parent c0e2972717
commit 378ef07893
10 changed files with 54 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
Main.hs
View File

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

3
backends/AnalyseAsm.hs
View File

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

3
backends/GenerateCBased.hs
View File

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

6
backends/GenerateCHP.hs
View File

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

3
checks/ArrayUsageCheck.hs
View File

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

4
common/EvalLiterals.hs
View File

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

3
common/OccamEDSL.hs
View File

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

36
frontends/ParseOccam.hs
View File

@ -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.

7
frontends/ParseRain.hs
View File

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

6
frontends/RainTypes.hs
View File

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