GF.Infra.SIO: The SIO monad now supports putStr in addition to putStrLn

Also included some unrelated minor changes.
This commit is contained in:
hallgren
2015-08-31 12:22:13 +00:00
parent 5cd0175051
commit e76fb3d9a1
4 changed files with 18 additions and 13 deletions

2
.ghci
View File

@@ -1,2 +1,2 @@
:set -isrc/compiler -isrc/binary -isrc/runtime/haskell -isrc/server -isrc/example-based -isrc/server/transfer -idist/build/autogen -idist/build/gf/gf-tmp :set -isrc/compiler -isrc/binary -isrc/runtime/haskell -isrc/server -isrc/example-based -isrc/server/transfer -idist/build/autogen -idist/build
:set -fwarn-unused-imports -optP-DSERVER_MODE -optP-DUSE_INTERRUPT -optP-DCC_LAZY -optP-include -optPdist/build/autogen/cabal_macros.h -odir dist/build/gf/gf-tmp -hidir dist/build/gf/gf-tmp -stubdir dist/build/gf/gf-tmp :set -fwarn-unused-imports -optP-DSERVER_MODE -optP-DUSE_INTERRUPT -optP-DCC_LAZY -optP-include -optPdist/build/autogen/cabal_macros.h -odir dist/build/gf/gf-tmp -hidir dist/build/gf/gf-tmp -stubdir dist/build/gf/gf-tmp

View File

@@ -551,7 +551,7 @@ strsFromTerm t = case t of
d0 <- strsFromTerm d d0 <- strsFromTerm d
v0 <- mapM (strsFromTerm . fst) vs v0 <- mapM (strsFromTerm . fst) vs
c0 <- mapM (strsFromTerm . snd) vs c0 <- mapM (strsFromTerm . snd) vs
let vs' = zip v0 c0 --let vs' = zip v0 c0
return [strTok (str2strings def) vars | return [strTok (str2strings def) vars |
def <- d0, def <- d0,
vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] | vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] |

View File

@@ -9,7 +9,7 @@ module GF.Infra.SIO(
-- * Unrestricted, safe operations -- * Unrestricted, safe operations
-- ** From the standard libraries -- ** From the standard libraries
getCPUTime,getCurrentDirectory,getLibraryDirectory, getCPUTime,getCurrentDirectory,getLibraryDirectory,
newStdGen,print,putStrLn, newStdGen,print,putStr,putStrLn,
-- ** Specific to GF -- ** Specific to GF
importGrammar,importSource, importGrammar,importSource,
#ifdef C_RUNTIME #ifdef C_RUNTIME
@@ -22,11 +22,11 @@ module GF.Infra.SIO(
-- Output to stdout will /not/ be captured or redirected. -- Output to stdout will /not/ be captured or redirected.
restricted,restrictedSystem restricted,restrictedSystem
) where ) where
import Prelude hiding (putStrLn,print) import Prelude hiding (putStr,putStrLn,print)
import Control.Applicative(Applicative(..)) import Control.Applicative(Applicative(..))
import Control.Monad(liftM,ap) import Control.Monad(liftM,ap)
import Control.Monad.Trans(MonadTrans(..)) import Control.Monad.Trans(MonadTrans(..))
import System.IO(hPutStrLn,hFlush,stdout) import System.IO(hPutStr,hFlush,stdout)
import GF.System.Catch(try) import GF.System.Catch(try)
import System.Process(system) import System.Process(system)
import System.Environment(getEnv) import System.Environment(getEnv)
@@ -45,8 +45,8 @@ import qualified PGF2
-- * The SIO monad -- * The SIO monad
type PutStrLn = String -> IO () type PutStr = String -> IO ()
newtype SIO a = SIO {unS::PutStrLn->IO a} newtype SIO a = SIO {unS::PutStr->IO a}
instance Functor SIO where fmap = liftM instance Functor SIO where fmap = liftM
@@ -62,9 +62,11 @@ instance Output SIO where
ePutStr = lift0 . ePutStr ePutStr = lift0 . ePutStr
ePutStrLn = lift0 . ePutStrLn ePutStrLn = lift0 . ePutStrLn
putStrLnE = putStrLnFlush putStrLnE = putStrLnFlush
--putStrE = --- !!! putStrE = putStr
class MonadSIO m where liftSIO :: SIO a -> m a class {- Monad m => -} MonadSIO m where liftSIO :: SIO a -> m a
-- ^ If the Monad m superclass is included, then the generic instance
-- for monad transformers below would require UndecidableInstances
instance MonadSIO SIO where liftSIO = id instance MonadSIO SIO where liftSIO = id
@@ -77,16 +79,17 @@ instance (MonadTrans t,Monad m,MonadSIO m) => MonadSIO (t m) where
runSIO = hRunSIO stdout runSIO = hRunSIO stdout
-- | Redirect 'stdout' to the given handle -- | Redirect 'stdout' to the given handle
hRunSIO h sio = unS sio (\s->hPutStrLn h s>>hFlush h) hRunSIO h sio = unS sio (\s->hPutStr h s>>hFlush h)
-- | Capture 'stdout' -- | Capture 'stdout'
captureSIO :: SIO a -> IO (String,a)
captureSIO sio = do ch <- newChan captureSIO sio = do ch <- newChan
result <- unS sio (writeChan ch . Just) result <- unS sio (writeChan ch . Just)
writeChan ch Nothing writeChan ch Nothing
output <- fmap takeJust (getChanContents ch) output <- fmap takeJust (getChanContents ch)
return (output,result) return (output,result)
where where
takeJust (Just xs:ys) = xs++'\n':takeJust ys takeJust (Just xs:ys) = xs++takeJust ys
takeJust _ = [] takeJust _ = []
-- * Restricted accesss to arbitrary (potentially unsafe) IO operations -- * Restricted accesss to arbitrary (potentially unsafe) IO operations
@@ -105,8 +108,10 @@ restrictedIO io =
lift0 io = SIO $ const io lift0 io = SIO $ const io
lift1 f io = SIO $ f . unS io lift1 f io = SIO $ f . unS io
putStr = putStrFlush
putStrFlush s = SIO ($ s)
putStrLn = putStrLnFlush putStrLn = putStrLnFlush
putStrLnFlush s = SIO ($ s) putStrLnFlush s = putStr s >> putStrFlush "\n"
print x = putStrLn (show x) print x = putStrLn (show x)
getCPUTime = lift0 IO.getCPUTime getCPUTime = lift0 IO.getCPUTime

View File

@@ -517,7 +517,7 @@ type Continuation = TrieMap.TrieMap Token ActiveSet
getContinuationInfo :: ParseState -> Map.Map [Token] [(FunId, CId, String)] getContinuationInfo :: ParseState -> Map.Map [Token] [(FunId, CId, String)]
getContinuationInfo pstate = Map.map (map f . Set.toList) contMap getContinuationInfo pstate = Map.map (map f . Set.toList) contMap
where where
PState abstr concr chart cont = pstate PState _abstr concr _chart cont = pstate
contMap = Map.fromList (TrieMap.toList cont) -- always get [([], _::ActiveSet)] contMap = Map.fromList (TrieMap.toList cont) -- always get [([], _::ActiveSet)]
f :: Active -> (FunId,CId,String) f :: Active -> (FunId,CId,String)
f (Active int dotpos funid seqid pargs ak) = (funid, cid, seq) f (Active int dotpos funid seqid pargs ak) = (funid, cid, seq)