mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-11 05:49:31 -06:00
365 lines
11 KiB
Haskell
365 lines
11 KiB
Haskell
{-# 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.Devel.UseIO where
|
|
|
|
import GF.Data.Operations
|
|
import GF.Devel.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.CPUTime
|
|
import Control.Monad
|
|
|
|
#ifdef mingw32_HOST_OS
|
|
import System.Win32.DLL
|
|
import System.FilePath.Windows
|
|
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
|
|
|
|
isPathSep :: Char -> Bool
|
|
isPathSep c = c == ':' || c == ';'
|
|
|
|
isSep :: Char -> Bool
|
|
isSep c = c == '/' || c == '\\'
|
|
|
|
getFilePath :: [FilePath] -> String -> IO (Maybe FilePath)
|
|
getFilePath ps file = 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 = prefixPathName 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 (justInitPath 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
|
|
|
|
getLibraryPath :: IO FilePath
|
|
getLibraryPath =
|
|
catch
|
|
(getEnv "GF_LIB_PATH")
|
|
#ifdef mingw32_HOST_OS
|
|
(\_ -> do exepath <- getModuleFileName nullPtr
|
|
let (path,_) = splitFileName exepath
|
|
canonicalizePath (combine path "../lib"))
|
|
#else
|
|
(const (return libdir))
|
|
#endif
|
|
|
|
-- | first var is lib prefix, second is like class path
|
|
-- | path in environment variable has lower priority
|
|
extendPathEnv :: String -> String -> [FilePath] -> IO [FilePath]
|
|
extendPathEnv lib var ps = do
|
|
b <- getLibraryPath -- e.g. GF_LIB_PATH
|
|
s <- catch (getEnv var) (const (return "")) -- e.g. GF_GRAMMAR_PATH
|
|
let fs = pFilePaths s
|
|
let ss = ps ++ fs
|
|
liftM concat $ mapM allSubdirs $ ss ++ [b ++ "/" ++ s | s <- ss ++ ["prelude"]]
|
|
|
|
pFilePaths :: String -> [FilePath]
|
|
pFilePaths s = case break isPathSep s of
|
|
(f,_:cs) -> f : pFilePaths cs
|
|
(f,_) -> [f]
|
|
|
|
getFilePaths :: String -> IO [FilePath]
|
|
getFilePaths s = do
|
|
let ps = pFilePaths s
|
|
liftM concat $ mapM allSubdirs ps
|
|
|
|
getSubdirs :: FilePath -> IO [FilePath]
|
|
getSubdirs p = do
|
|
fs <- catch (getDirectoryContents p) (const $ return [])
|
|
fps <- mapM getPermissions (map (prefixPathName p) fs)
|
|
let ds = [f | (f,p) <- zip fs fps, searchable p, not (take 1 f==".")]
|
|
return ds
|
|
|
|
allSubdirs :: FilePath -> IO [FilePath]
|
|
allSubdirs [] = return [[]]
|
|
allSubdirs p = case last p of
|
|
'*' -> do
|
|
fs <- getSubdirs (init p)
|
|
return [prefixPathName (init p) f | f <- fs]
|
|
_ -> return [p]
|
|
|
|
prefixPathName :: String -> FilePath -> FilePath
|
|
prefixPathName p f = case f of
|
|
c:_ | isSep c -> f -- do not prefix [Unix style] absolute paths
|
|
_ -> case p of
|
|
"" -> f
|
|
_ -> p ++ "/" ++ f -- note: / actually works on windows
|
|
|
|
justInitPath :: FilePath -> FilePath
|
|
justInitPath = reverse . drop 1 . dropWhile (not . isSep) . reverse
|
|
|
|
nameAndSuffix :: FilePath -> (String,String)
|
|
nameAndSuffix file = case span (/='.') (reverse file) of
|
|
(_,[]) -> (file,[])
|
|
(xet,deman) -> if any isSep xet
|
|
then (file,[]) -- cover cases like "foo.bar/baz"
|
|
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 (not . isSep) . reverse
|
|
|
|
suffixFile :: String -> FilePath -> FilePath
|
|
suffixFile suff file = file ++ "." ++ suff
|
|
|
|
justModuleName :: FilePath -> String
|
|
justModuleName = fileBody . justFileName
|
|
|
|
--
|
|
|
|
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
|
|
|
|
|
|
-- | forces verbosity
|
|
putPointEVerb :: Options -> String -> IOE a -> IOE a
|
|
putPointEVerb opts = putPointE (addOption beVerbose opts)
|
|
|
|
gfLibraryPath = "GF_LIB_PATH"
|
|
|
|
-- ((do {s <- readFile f; return (return s)}) )
|
|
readFileIOE :: FilePath -> IOE (String)
|
|
readFileIOE f = ioe $ catch (readFileStrict 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
|
|
--
|
|
-- FIXME: unix-specific, \/ is \\ on Windows
|
|
readFileLibraryIOE :: String -> FilePath -> IOE (FilePath, String)
|
|
readFileLibraryIOE ini f =
|
|
ioe $ catch ((do {s <- readFileStrict initPath; return (return (initPath,s))}))
|
|
(\_ -> tryLibrary ini f) where
|
|
tryLibrary :: String -> FilePath -> IO (Err (FilePath, String))
|
|
tryLibrary ini f =
|
|
catch (do {
|
|
lp <- getLibPath;
|
|
s <- readFileStrict (lp ++ f);
|
|
return (return (lp ++ f, s))
|
|
}) (\_ -> return (Bad (reportOn f)))
|
|
initPath = addInitFilePath ini f
|
|
getLibPath :: IO String
|
|
getLibPath = do {
|
|
lp <- catch (getEnv gfLibraryPath) (const (return libdir)) ;
|
|
return (if isSep (last lp) then lp else lp ++ ['/']);
|
|
}
|
|
reportOn f = "File " ++ f ++ " not found."
|
|
libPath ini f = f
|
|
addInitFilePath ini file = case file of
|
|
c:_ | isSep c -> 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
|
|
|