mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-22 17:42:51 -06:00
GF.Infra.SIO: The SIO monad now supports putStr in addition to putStrLn
Also included some unrelated minor changes.
This commit is contained in:
2
.ghci
2
.ghci
@@ -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
|
||||||
|
|||||||
@@ -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] |
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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)
|
||||||
|
|||||||
Reference in New Issue
Block a user