summaryrefslogtreecommitdiff
path: root/src/GF/Infra/UseIO.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF/Infra/UseIO.hs')
-rw-r--r--src/GF/Infra/UseIO.hs330
1 files changed, 0 insertions, 330 deletions
diff --git a/src/GF/Infra/UseIO.hs b/src/GF/Infra/UseIO.hs
deleted file mode 100644
index 4125a0417..000000000
--- a/src/GF/Infra/UseIO.hs
+++ /dev/null
@@ -1,330 +0,0 @@
-{-# OPTIONS -cpp #-}
-----------------------------------------------------------------------
--- |
--- Module : UseIO
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/08/08 09:01:25 $
--- > CVS $Author: peb $
--- > CVS $Revision: 1.17 $
---
--- (Description of the module)
------------------------------------------------------------------------------
-
-module GF.Infra.UseIO where
-
-import GF.Data.Operations
-import GF.System.Arch (prCPU)
-import GF.Infra.Option
-import GF.Today (libdir)
-
-import System.Directory
-import System.IO
-import System.IO.Error
-import System.Environment
-import System.FilePath
-import Control.Monad
-
-#ifdef mingw32_HOST_OS
-import System.Win32.DLL
-import Foreign.Ptr
-#endif
-
-
-putShow' :: Show a => (c -> a) -> c -> IO ()
-putShow' f = putStrLn . show . length . show . f
-
-putIfVerb :: Options -> String -> IO ()
-putIfVerb opts msg =
- if oElem beVerbose opts
- then putStrLn msg
- else return ()
-
-putIfVerbW :: Options -> String -> IO ()
-putIfVerbW opts msg =
- if oElem beVerbose opts
- then putStr (' ' : msg)
- else return ()
-
--- | obsolete with IOE monad
-errIO :: a -> Err a -> IO a
-errIO = errOptIO noOptions
-
-errOptIO :: Options -> a -> Err a -> IO a
-errOptIO os e m = case m of
- Ok x -> return x
- Bad k -> do
- putIfVerb os k
- return e
-
-prOptCPU :: Options -> Integer -> IO Integer
-prOptCPU opts = if (oElem noCPU opts) then (const (return 0)) else prCPU
-
-putCPU :: IO ()
-putCPU = do
- prCPU 0
- return ()
-
-putPoint :: Show a => Options -> String -> IO a -> IO a
-putPoint = putPoint' id
-
-putPoint' :: Show a => (c -> a) -> Options -> String -> IO c -> IO c
-putPoint' f opts msg act = do
- let sil x = if oElem beSilent opts then return () else x
- ve x = if oElem beVerbose opts then x else return ()
- ve $ putStrLn msg
- a <- act
- ve $ putShow' f a
- ve $ putCPU
- return a
-
-readFileStrict :: String -> IO String
-readFileStrict f = do
- s <- readFile f
- return $ seq (length s) ()
- return s
-
-readFileIf = readFileIfs readFile
-readFileIfStrict = readFileIfs readFileStrict
-
-readFileIfs rf f = catch (rf f) (\_ -> reportOn f) where
- reportOn f = do
- putStrLnFlush ("File " ++ f ++ " does not exist. Returned empty string")
- return ""
-
-type FileName = String
-type InitPath = String
-type FullPath = String
-
-getFilePath :: [FilePath] -> String -> IO (Maybe FilePath)
-getFilePath ps file = do
- getFilePathMsg ("file" +++ file +++ "not found\n") ps file
-
-getFilePathMsg :: String -> [FilePath] -> String -> IO (Maybe FilePath)
-getFilePathMsg msg paths file = get paths where
- get [] = putStrFlush msg >> return Nothing
- get (p:ps) = do
- let pfile = p </> file
- exist <- doesFileExist pfile
- if exist then return (Just pfile) else get ps
---- catch (readFileStrict pfile >> return (Just pfile)) (\_ -> get ps)
-
-readFileIfPath :: [FilePath] -> String -> IOE (FilePath,String)
-readFileIfPath paths file = do
- mpfile <- ioeIO $ getFilePath paths file
- case mpfile of
- Just pfile -> do
- s <- ioeIO $ readFileStrict pfile
- return (dropFileName pfile,s)
- _ -> ioeErr $ Bad ("File " ++ file ++ " does not exist.")
-
-doesFileExistPath :: [FilePath] -> String -> IOE Bool
-doesFileExistPath paths file = do
- mpfile <- ioeIO $ getFilePathMsg "" paths file
- return $ maybe False (const True) mpfile
-
-gfLibraryPath = "GF_LIB_PATH"
-
--- | environment variable for grammar search path
-gfGrammarPathVar = "GF_GRAMMAR_PATH"
-
-getLibraryPath :: IO FilePath
-getLibraryPath =
- catch
- (getEnv gfLibraryPath)
-#ifdef mingw32_HOST_OS
- (\_ -> do exepath <- getModuleFileName nullPtr
- let (path,_) = splitFileName exepath
- canonicalizePath (combine path "../lib"))
-#else
- (const (return libdir))
-#endif
-
--- | extends the search path with the
--- 'gfLibraryPath' and 'gfGrammarPathVar'
--- environment variables. Returns only existing paths.
-extendPathEnv :: [FilePath] -> IO [FilePath]
-extendPathEnv ps = do
- b <- getLibraryPath -- e.g. GF_LIB_PATH
- s <- catch (getEnv gfGrammarPathVar) (const (return "")) -- e.g. GF_GRAMMAR_PATH
- let ss = ps ++ splitSearchPath s
- liftM concat $ mapM allSubdirs $ ss ++ [b </> s | s <- ss ++ ["prelude"]]
- where
- allSubdirs :: FilePath -> IO [FilePath]
- allSubdirs [] = return [[]]
- allSubdirs p = case last p of
- '*' -> do let path = init p
- fs <- getSubdirs path
- return [path </> f | f <- fs]
- _ -> do exists <- doesDirectoryExist p
- if exists
- then return [p]
- else return []
-
-getSubdirs :: FilePath -> IO [FilePath]
-getSubdirs dir = do
- fs <- catch (getDirectoryContents dir) (const $ return [])
- foldM (\fs f -> do let fpath = dir </> f
- p <- getPermissions fpath
- if searchable p && not (take 1 f==".")
- then return (fpath:fs)
- else return fs ) [] fs
-
-justModuleName :: FilePath -> String
-justModuleName = dropExtension . takeFileName
-
-splitInModuleSearchPath :: String -> [FilePath]
-splitInModuleSearchPath s = case break isPathSep s of
- (f,_:cs) -> f : splitInModuleSearchPath cs
- (f,_) -> [f]
- where
- isPathSep :: Char -> Bool
- isPathSep c = c == ':' || c == ';'
-
---
-
-getLineWell :: IO String -> IO String
-getLineWell ios =
- catch getLine (\e -> if (isEOFError e) then ios else ioError e)
-
-putStrFlush :: String -> IO ()
-putStrFlush s = putStr s >> hFlush stdout
-
-putStrLnFlush :: String -> IO ()
-putStrLnFlush s = putStrLn s >> hFlush stdout
-
--- * a generic quiz session
-
-type QuestionsAndAnswers = [(String, String -> (Integer,String))]
-
-teachDialogue :: QuestionsAndAnswers -> String -> IO ()
-teachDialogue qas welc = do
- putStrLn $ welc ++++ genericTeachWelcome
- teach (0,0) qas
- where
- teach _ [] = do putStrLn "Sorry, ran out of problems"
- teach (score,total) ((question,grade):quas) = do
- putStr ("\n" ++ question ++ "\n> ")
- answer <- getLine
- if (answer == ".") then return () else do
- let (result, feedback) = grade answer
- score' = score + result
- total' = total + 1
- putStr (feedback ++++ "Score" +++ show score' ++ "/" ++ show total')
- if (total' > 9 && fromInteger score' / fromInteger total' >= 0.75)
- then do putStrLn "\nCongratulations - you passed!"
- else teach (score',total') quas
-
- genericTeachWelcome =
- "The quiz is over when you have done at least 10 examples" ++++
- "with at least 75 % success." +++++
- "You can interrupt the quiz by entering a line consisting of a dot ('.').\n"
-
-
--- * IO monad with error; adapted from state monad
-
-newtype IOE a = IOE (IO (Err a))
-
-appIOE :: IOE a -> IO (Err a)
-appIOE (IOE iea) = iea
-
-ioe :: IO (Err a) -> IOE a
-ioe = IOE
-
-ioeIO :: IO a -> IOE a
-ioeIO io = ioe (io >>= return . return)
-
-ioeErr :: Err a -> IOE a
-ioeErr = ioe . return
-
-instance Monad IOE where
- return a = ioe (return (return a))
- IOE c >>= f = IOE $ do
- x <- c -- Err a
- appIOE $ err ioeBad f x -- f :: a -> IOE a
-
-ioeBad :: String -> IOE a
-ioeBad = ioe . return . Bad
-
-useIOE :: a -> IOE a -> IO a
-useIOE a ioe = appIOE ioe >>= err (\s -> putStrLn s >> return a) return
-
-foldIOE :: (a -> b -> IOE a) -> a -> [b] -> IOE (a, Maybe String)
-foldIOE f s xs = case xs of
- [] -> return (s,Nothing)
- x:xx -> do
- ev <- ioeIO $ appIOE (f s x)
- case ev of
- Ok v -> foldIOE f v xx
- Bad m -> return $ (s, Just m)
-
-putStrLnE :: String -> IOE ()
-putStrLnE = ioeIO . putStrLnFlush
-
-putStrE :: String -> IOE ()
-putStrE = ioeIO . putStrFlush
-
--- this is more verbose
-putPointE :: Options -> String -> IOE a -> IOE a
-putPointE = putPointEgen (oElem beSilent)
-
--- this is less verbose
-putPointEsil :: Options -> String -> IOE a -> IOE a
-putPointEsil = putPointEgen (not . oElem beVerbose)
-
-putPointEgen :: (Options -> Bool) -> Options -> String -> IOE a -> IOE a
-putPointEgen cond opts msg act = do
- let ve x = if cond opts then return () else x
- ve $ ioeIO $ putStrFlush msg
- a <- act
---- ve $ ioeIO $ putShow' id a --- replace by a statistics command
- ve $ ioeIO $ putStrFlush " "
- ve $ ioeIO $ putCPU
- return a
-{-
-putPointE :: Options -> String -> IOE a -> IOE a
-putPointE opts msg act = do
- let ve x = if oElem beVerbose opts then x else return ()
- ve $ putStrE msg
- a <- act
---- ve $ ioeIO $ putShow' id a --- replace by a statistics command
- ve $ ioeIO $ putCPU
- return a
--}
-
--- | forces verbosity
-putPointEVerb :: Options -> String -> IOE a -> IOE a
-putPointEVerb opts = putPointE (addOption beVerbose opts)
-
--- ((do {s <- readFile f; return (return s)}) )
-readFileIOE :: FilePath -> IOE (String)
-readFileIOE f = ioe $ catch (readFileStrict f >>= return . return)
- (\e -> return (Bad (show e)))
-
--- | like readFileIOE but look also in the GF library if file not found
---
--- intended semantics: if file is not found, try @\$GF_LIB_PATH\/file@
--- (even if file is an absolute path, but this should always fail)
--- it returns not only contents of the file, but also the path used
-readFileLibraryIOE :: String -> FilePath -> IOE (FilePath, String)
-readFileLibraryIOE ini f = ioe $ do
- lp <- getLibraryPath
- tryRead ini $ \_ ->
- tryRead lp $ \e ->
- return (Bad (show e))
- where
- tryRead path onError =
- catch (readFileStrict fpath >>= \s -> return (return (fpath,s)))
- onError
- where
- fpath = path </> f
-
--- | example
-koeIOE :: IO ()
-koeIOE = useIOE () $ do
- s <- ioeIO $ getLine
- s2 <- ioeErr $ mapM (!? 2) $ words s
- ioeIO $ putStrLn s2
-
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 05:15:23 +0000