mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-12 12:42:50 -06:00
compiler "gfc" in GF/Devel
This commit is contained in:
aarne
344
src/GF/Devel/UseIO.hs
Normal file
344
src/GF/Devel/UseIO.hs
Normal file
@@ -0,0 +1,344 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- 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 Control.Monad
|
||||
|
||||
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
|
||||
|
||||
-- | 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 <- catch (getEnv lib) (const (return libdir)) -- 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]
|
||||
|
||||
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
|
||||
|
||||
Reference in New Issue
Block a user