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.hs245
1 files changed, 245 insertions, 0 deletions
diff --git a/src/GF/Infra/UseIO.hs b/src/GF/Infra/UseIO.hs
new file mode 100644
index 000000000..bd9d9e22a
--- /dev/null
+++ b/src/GF/Infra/UseIO.hs
@@ -0,0 +1,245 @@
+module UseIO where
+
+import Operations
+import Arch (prCPU)
+import Option
+
+import IO
+import System
+import Monad
+
+putShow' :: Show a => (c -> a) -> c -> IO ()
+putShow' f = putStrLn . show . length . show . f
+
+putIfVerb opts msg =
+ if oElem beVerbose opts
+ then putStrLn msg
+ else return ()
+
+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 opts = if (oElem noCPU opts) then (const (return 0)) else prCPU
+
+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
+
+readFileIf :: String -> IO String
+readFileIf f = catch (readFile f) (\_ -> reportOn f) where
+ reportOn f = do
+ putStrLnFlush ("File " ++ f ++ " does not exist. Returned empty string")
+ return ""
+
+getFilePath :: [FilePath] -> String -> IO (Maybe FilePath)
+getFilePath paths file = get paths where
+ get [] = putStrLnFlush ("file" +++ file +++ "not found") >> return Nothing
+ get (p:ps) = let pfile = prefixPathName p file in
+ catch (readFile 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 $ readFile pfile
+ return (justInitPath pfile,s)
+ _ -> ioeErr $ Bad ("File " ++ file ++ " does not exist.")
+
+pFilePaths :: String -> [FilePath]
+pFilePaths s = case span (/=':') s of
+ (f,_:cs) -> f : pFilePaths cs
+ (f,_) -> [f]
+
+prefixPathName :: String -> FilePath -> FilePath
+prefixPathName "" f = f
+prefixPathName p f = p ++ "/" ++ f
+
+justInitPath :: FilePath -> FilePath
+justInitPath = reverse . drop 1 . dropWhile (/='/') . reverse
+
+nameAndSuffix :: FilePath -> (String,String)
+nameAndSuffix file = case span (/='.') (reverse file) of
+ (_,[]) -> (file,[])
+ (xet,deman) -> if elem '/' xet
+ then (file,[])
+ else (reverse $ drop 1 deman,reverse xet)
+
+unsuffixFile, fileBody :: FilePath -> String
+unsuffixFile = fst . nameAndSuffix
+fileBody = unsuffixFile
+
+fileSuffix :: FilePath -> String
+fileSuffix = snd . nameAndSuffix
+
+justFileName :: FilePath -> String
+justFileName = reverse . takeWhile (/='/') . reverse
+
+suffixFile :: String -> FilePath -> FilePath
+suffixFile suff file = file ++ "." ++ suff
+
+--
+
+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
+
+putStrLnE :: String -> IOE ()
+putStrLnE = ioeIO . putStrLnFlush
+
+putStrE :: String -> IOE ()
+putStrE = ioeIO . putStrFlush
+
+putPointE :: Options -> String -> IOE a -> IOE a
+putPointE opts msg act = do
+ let ve x = if oElem beVerbose opts then x else return ()
+ 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 (readFile f >>= return . return)
+ (\_ -> return (Bad (reportOn f))) where
+ reportOn f = "File " ++ f ++ " not found."
+
+-- 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 $ catch ((do {s <- readFile initPath; return (return (initPath,s))}))
+ (\_ -> tryLibrary ini f) where
+ tryLibrary :: String -> FilePath -> IO (Err (FilePath, String))
+ tryLibrary ini f =
+ catch (do {
+ lp <- getLibPath;
+ s <- readFile (lp ++ f);
+ return (return (lp ++ f, s))
+ }) (\_ -> return (Bad (reportOn f)))
+ initPath = addInitFilePath ini f
+ getLibPath :: IO String
+ getLibPath = do {
+ lp <- getEnv "GF_LIB_PATH";
+ return (if last lp == '/' then lp else lp ++ ['/']);
+ }
+ reportOn f = "File " ++ f ++ " not found."
+ libPath ini f = f
+ addInitFilePath ini file = case file of
+ '/':_ -> file -- absolute path name
+ _ -> ini ++ file -- relative path name
+
+
+-- 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 16:26:05 +0000