forked from GitHub/gf-core
remove all files that aren't used in GF-3.0
This commit is contained in:
kr.angelov
@@ -1,43 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Comments
|
||||
-- Maintainer : (Maintainer)
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/21 16:22:34 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.5 $
|
||||
--
|
||||
-- comment removal
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Infra.Comments ( remComments
|
||||
) where
|
||||
|
||||
-- | comment removal : line tails prefixed by -- as well as chunks in @{- ... -}@
|
||||
remComments :: String -> String
|
||||
remComments s =
|
||||
case s of
|
||||
'"':s2 -> '"':pass remComments s2 -- comment marks in quotes not removed!
|
||||
'{':'-':cs -> readNested cs
|
||||
'-':'-':cs -> readTail cs
|
||||
c:cs -> c : remComments cs
|
||||
[] -> []
|
||||
where
|
||||
readNested t =
|
||||
case t of
|
||||
'"':s2 -> '"':pass readNested s2
|
||||
'-':'}':cs -> remComments cs
|
||||
_:cs -> readNested cs
|
||||
[] -> []
|
||||
readTail t =
|
||||
case t of
|
||||
'\n':cs -> '\n':remComments cs
|
||||
_:cs -> readTail cs
|
||||
[] -> []
|
||||
pass f t =
|
||||
case t of
|
||||
'"':s2 -> '"': f s2
|
||||
c:s2 -> c:pass f s2
|
||||
_ -> t
|
||||
@@ -1,127 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/06/17 14:15:18 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.4 $
|
||||
--
|
||||
-- Pretty-printing
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Infra.Print
|
||||
(module GF.Infra.PrintClass
|
||||
) where
|
||||
|
||||
-- haskell modules:
|
||||
import Data.Char (toUpper)
|
||||
-- gf modules:
|
||||
|
||||
import GF.Infra.PrintClass
|
||||
import GF.Data.Operations (Err(..))
|
||||
import GF.Infra.Ident (Ident(..))
|
||||
import GF.Canon.AbsGFC
|
||||
import GF.CF.CF
|
||||
import GF.CF.CFIdent
|
||||
import qualified GF.Canon.PrintGFC as P
|
||||
|
||||
------------------------------------------------------------
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
instance Print Ident where
|
||||
prt = P.printTree
|
||||
|
||||
instance Print Term where
|
||||
prt (Arg arg) = prt arg
|
||||
prt (con `Par` []) = prt con
|
||||
prt (con `Par` terms) = prt con ++ "(" ++ prtSep ", " terms ++ ")"
|
||||
prt (LI ident) = "$" ++ prt ident
|
||||
prt (R record) = "{" ++ prtSep "; " record ++ "}"
|
||||
prt (term `P` lbl) = prt term ++ "." ++ prt lbl
|
||||
prt (T _ table) = "table{" ++ prtSep "; " table ++ "}"
|
||||
prt (V _ terms) = "values{" ++ prtSep "; " terms ++ "}"
|
||||
prt (term `S` sel) = "(" ++ prt term ++ " ! " ++ prt sel ++ ")"
|
||||
prt (FV terms) = "variants{" ++ prtSep " | " terms ++ "}"
|
||||
prt (term `C` term') = prt term ++ " " ++ prt term'
|
||||
prt (EInt n) = prt n
|
||||
prt (K tokn) = show (prt tokn)
|
||||
prt (E) = show ""
|
||||
|
||||
instance Print Patt where
|
||||
prt (con `PC` []) = prt con
|
||||
prt (con `PC` pats) = prt con ++ "(" ++ prtSep "," pats ++ ")"
|
||||
prt (PV ident) = "$" ++ prt ident
|
||||
prt (PW) = "_"
|
||||
prt (PR record) = "{" ++ prtSep ";" record ++ "}"
|
||||
|
||||
instance Print Label where
|
||||
prt (L ident) = prt ident
|
||||
prt (LV nr) = "$" ++ show nr
|
||||
|
||||
instance Print Tokn where
|
||||
prt (KS str) = str
|
||||
prt tokn@(KP _ _) = show tokn
|
||||
|
||||
instance Print ArgVar where
|
||||
prt (A cat argNr) = prt cat ++ "#" ++ show argNr
|
||||
|
||||
instance Print CIdent where
|
||||
prt (CIQ _ ident) = prt ident
|
||||
|
||||
instance Print Case where
|
||||
prt (pats `Cas` term) = prtSep "|" pats ++ "=>" ++ prt term
|
||||
|
||||
instance Print Assign where
|
||||
prt (lbl `Ass` term) = prt lbl ++ "=" ++ prt term
|
||||
|
||||
instance Print PattAssign where
|
||||
prt (lbl `PAss` pat) = prt lbl ++ "=" ++ prt pat
|
||||
|
||||
instance Print Atom where
|
||||
prt (AC c) = prt c
|
||||
prt (AD c) = "<" ++ prt c ++ ">"
|
||||
prt (AV i) = "$" ++ prt i
|
||||
prt (AM n) = "?" ++ show n
|
||||
prt atom = show atom
|
||||
|
||||
instance Print CType where
|
||||
prt (RecType rtype) = "{" ++ prtSep "; " rtype ++ "}"
|
||||
prt (Table ptype vtype) = "(" ++ prt ptype ++ " => " ++ prt vtype ++ ")"
|
||||
prt (Cn cn) = prt cn
|
||||
prt (TStr) = "Str"
|
||||
|
||||
instance Print Labelling where
|
||||
prt (lbl `Lbg` ctype) = prt lbl ++ ":" ++ prt ctype
|
||||
|
||||
instance Print CFItem where
|
||||
prt (CFTerm regexp) = prt regexp
|
||||
prt (CFNonterm cat) = prt cat
|
||||
|
||||
instance Print RegExp where
|
||||
prt (RegAlts words) = "("++prtSep "|" words ++ ")"
|
||||
prt (RegSpec tok) = prt tok
|
||||
|
||||
instance Print CFTok where
|
||||
prt (TS str) = str
|
||||
prt (TC (c:str)) = '(' : toUpper c : ')' : str
|
||||
prt (TL str) = show str
|
||||
prt (TI n) = "#" ++ show n
|
||||
prt (TV x) = "$" ++ prt x
|
||||
prt (TM n s) = "?" ++ show n ++ s
|
||||
|
||||
instance Print CFCat where
|
||||
prt (CFCat (cid,lbl)) = prt cid ++ "-" ++ prt lbl
|
||||
|
||||
instance Print CFFun where
|
||||
prt (CFFun fun) = prt (fst fun)
|
||||
|
||||
instance Print Exp where
|
||||
prt = P.printTree
|
||||
|
||||
instance Print a => Print (Err a) where
|
||||
prt (Ok a) = prt a
|
||||
prt (Bad str) = str
|
||||
|
||||
@@ -1,362 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : ReadFiles
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/11/11 23:24:34 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.26 $
|
||||
--
|
||||
-- Decide what files to read as function of dependencies and time stamps.
|
||||
--
|
||||
-- make analysis for GF grammar modules. AR 11\/6\/2003--24\/2\/2004
|
||||
--
|
||||
-- to find all files that have to be read, put them in dependency order, and
|
||||
-- decide which files need recompilation. Name @file.gf@ is returned for them,
|
||||
-- and @file.gfc@ or @file.gfr@ otherwise.
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Infra.ReadFiles (-- * Heading 1
|
||||
getAllFiles,fixNewlines,ModName,getOptionsFromFile,
|
||||
-- * Heading 2
|
||||
gfcFile,gfFile,gfrFile,isGFC,resModName,isOldFile
|
||||
) where
|
||||
|
||||
import GF.System.Arch (selectLater, modifiedFiles, ModTime, getModTime,laterModTime)
|
||||
|
||||
import GF.Infra.Option
|
||||
import GF.Data.Operations
|
||||
import GF.Infra.UseIO
|
||||
|
||||
import System
|
||||
import Data.Char
|
||||
import Control.Monad
|
||||
import Data.List
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
|
||||
type ModName = String
|
||||
type ModEnv = [(ModName,ModTime)]
|
||||
|
||||
getAllFiles :: Options -> [InitPath] -> ModEnv -> FileName -> IOE [FullPath]
|
||||
getAllFiles opts ps env file = do
|
||||
|
||||
-- read module headers from all files recursively
|
||||
ds0 <- getImports ps file
|
||||
let ds = [((snd m,map fst ms),p) | ((m,ms),p) <- ds0]
|
||||
if oElem beVerbose opts
|
||||
then ioeIO $ putStrLn $ "all modules:" +++ show (map (fst . fst) ds)
|
||||
else return ()
|
||||
-- get a topological sorting of files: returns file names --- deletes paths
|
||||
ds1 <- ioeErr $ either
|
||||
return
|
||||
(\ms -> Bad $ "circular modules" +++
|
||||
unwords (map show (head ms))) $ topoTest $ map fst ds
|
||||
|
||||
-- associate each file name with its path --- more optimal: save paths in ds1
|
||||
let paths = [(f,p) | ((f,_),p) <- ds]
|
||||
let pds1 = [(p,f) | f <- ds1, Just p <- [lookup f paths]]
|
||||
if oElem fromSource opts
|
||||
then return [gfFile (p </> f) | (p,f) <- pds1]
|
||||
else do
|
||||
|
||||
|
||||
ds2 <- ioeIO $ mapM (selectFormat opts env) pds1
|
||||
|
||||
let ds4 = needCompile opts (map fst ds0) ds2
|
||||
return ds4
|
||||
|
||||
-- to decide whether to read gf or gfc, or if in env; returns full file path
|
||||
|
||||
data CompStatus =
|
||||
CSComp -- compile: read gf
|
||||
| CSRead -- read gfc
|
||||
| CSEnv -- gfc is in env
|
||||
| CSEnvR -- also gfr is in env
|
||||
| CSDont -- don't read at all
|
||||
| CSRes -- read gfr
|
||||
deriving (Eq,Show)
|
||||
|
||||
-- for gfc, we also return ModTime to cope with earlier compilation of libs
|
||||
|
||||
selectFormat :: Options -> ModEnv -> (InitPath,ModName) ->
|
||||
IO (ModName,(InitPath,(CompStatus,Maybe ModTime)))
|
||||
|
||||
selectFormat opts env (p,f) = do
|
||||
let pf = p </> f
|
||||
let mtenv = lookup f env -- Nothing if f is not in env
|
||||
let rtenv = lookup (resModName f) env
|
||||
let fromComp = oElem isCompiled opts -- i -gfc
|
||||
mtgfc <- getModTime $ gfcFile pf
|
||||
mtgf <- getModTime $ gfFile pf
|
||||
let stat = case (rtenv,mtenv,mtgfc,mtgf) of
|
||||
-- (_,Just tenv,_,_) | fromComp -> (CSEnv, Just tenv)
|
||||
(_,_,Just tgfc,_) | fromComp -> (CSRead,Just tgfc)
|
||||
-- (Just tenv,_,_,Just tgf) | laterModTime tenv tgf -> (CSEnvR,Just tenv)
|
||||
-- (_,Just tenv,_,Just tgf) | laterModTime tenv tgf -> (CSEnv, Just tenv)
|
||||
(_,_,Just tgfc,Just tgf) | laterModTime tgfc tgf ->
|
||||
case mtenv of
|
||||
-- Just tenv | laterModTime tenv tgfc -> (CSEnv,Just tenv)
|
||||
_ -> (CSRead,Just tgfc)
|
||||
|
||||
|
||||
-- (_,Just tenv,_,Nothing) -> (CSEnv,Just tenv) -- source does not exist
|
||||
(_,_,_, Nothing) -> (CSRead,Nothing) -- source does not exist
|
||||
_ -> (CSComp,Nothing)
|
||||
return $ (f, (p,stat))
|
||||
|
||||
needCompile :: Options ->
|
||||
[ModuleHeader] ->
|
||||
[(ModName,(InitPath,(CompStatus,Maybe ModTime)))] -> [FullPath]
|
||||
needCompile opts headers sfiles0 = paths $ res $ mark $ iter changed where
|
||||
|
||||
deps = [(snd m,map fst ms) | (m,ms) <- headers]
|
||||
typ m = maybe MTyOther id $ lookup m [(m,t) | ((t,m),_) <- headers]
|
||||
uses m = [(n,u) | ((_,n),ms) <- headers, (k,u) <- ms, k==m]
|
||||
stat0 m = maybe CSComp (fst . snd) $ lookup m sfiles0
|
||||
|
||||
allDeps = [(m,iterFix add ms) | (m,ms) <- deps] where
|
||||
add os = [m | o <- os, Just n <- [lookup o deps],m <- n]
|
||||
|
||||
-- only treat reused, interface, or instantiation if needed
|
||||
sfiles = sfiles0 ---- map relevant sfiles0
|
||||
relevant fp@(f,(p,(st,_))) =
|
||||
let us = uses f
|
||||
isUsed = not (null us)
|
||||
in
|
||||
if not (isUsed && all noComp us) then
|
||||
fp else
|
||||
if (elem (typ f) [] ---- MTyIncomplete, MTyIncResource]
|
||||
||
|
||||
(isUsed && all isAux us)) then
|
||||
(f,(p,(CSDont,Nothing))) else
|
||||
fp
|
||||
|
||||
isAux = flip elem [MUReuse,MUInstance,MUComplete] . snd
|
||||
noComp = flip elem [CSRead,CSEnv,CSEnvR] . stat0 . fst
|
||||
|
||||
-- mark as to be compiled those whose gfc is earlier than a deeper gfc
|
||||
sfiles1 = map compTimes sfiles
|
||||
compTimes fp@(f,(p,(_, Just t))) =
|
||||
if any (> t) [t' | Just fs <- [lookup f deps],
|
||||
f0 <- fs,
|
||||
Just (_,(_,Just t')) <- [lookup f0 sfiles]]
|
||||
then (f,(p,(CSComp, Nothing)))
|
||||
else fp
|
||||
compTimes fp = fp
|
||||
|
||||
-- start with the changed files themselves; returns [ModName]
|
||||
changed = [f | (f,(_,(CSComp,_))) <- sfiles1]
|
||||
|
||||
-- add other files that depend on some changed file; returns [ModName]
|
||||
iter np = let new = [f | (f,fs) <- deps,
|
||||
not (elem f np), any (flip elem np) fs]
|
||||
in if null new then np else (iter (new ++ np))
|
||||
|
||||
-- for each module in the full list, compile if depends on what needs compile
|
||||
-- returns [FullPath]
|
||||
mark cs = [(f,(path,st)) |
|
||||
(f,(path,(st0,_))) <- sfiles1,
|
||||
let st = if (elem f cs) then CSComp else st0]
|
||||
|
||||
|
||||
-- if a compilable file depends on a resource, read gfr instead of gfc/env
|
||||
-- but don't read gfr if already in env (by CSEnvR)
|
||||
-- Also read res if the option "retain" is present
|
||||
-- Also, if a "with" file has to be compiled, read its mother file from source
|
||||
|
||||
res cs = map mkRes cs where
|
||||
mkRes x@(f,(path,st)) | elem st [CSRead,CSEnv] = case typ f of
|
||||
t | (not (null [m | (m,(_,CSComp)) <- cs,
|
||||
Just ms <- [lookup m allDeps], elem f ms])
|
||||
|| oElem retainOpers opts)
|
||||
-> if elem t [MTyResource,MTyIncResource]
|
||||
then (f,(path,CSRes)) else
|
||||
if t == MTyIncomplete
|
||||
then (f,(path,CSComp)) else
|
||||
x
|
||||
_ -> x
|
||||
mkRes x = x
|
||||
|
||||
|
||||
|
||||
-- construct list of paths to read
|
||||
paths cs = [mkName f p st | (f,(p,st)) <- cs, elem st [CSComp, CSRead,CSRes]]
|
||||
|
||||
mkName f p st = mk (p </> f) where
|
||||
mk = case st of
|
||||
CSComp -> gfFile
|
||||
CSRead -> gfcFile
|
||||
CSRes -> gfrFile
|
||||
|
||||
isGFC :: FilePath -> Bool
|
||||
isGFC = (== ".gfc") . takeExtensions
|
||||
|
||||
gfcFile :: FilePath -> FilePath
|
||||
gfcFile f = addExtension f "gfc"
|
||||
|
||||
gfrFile :: FilePath -> FilePath
|
||||
gfrFile f = addExtension f "gfr"
|
||||
|
||||
gfFile :: FilePath -> FilePath
|
||||
gfFile f = addExtension f "gf"
|
||||
|
||||
resModName :: ModName -> ModName
|
||||
resModName = ('#':)
|
||||
|
||||
-- to get imports without parsing the whole files
|
||||
|
||||
getImports :: [InitPath] -> FileName -> IOE [(ModuleHeader,InitPath)]
|
||||
getImports ps = get [] where
|
||||
get ds file0 = do
|
||||
let name = dropExtension file0 ---- dropExtension file0
|
||||
(p,s) <- tryRead name
|
||||
let ((typ,mname),imps) = importsOfFile s
|
||||
let namebody = takeFileName name
|
||||
ioeErr $ testErr (mname == namebody) $
|
||||
"module name" +++ mname +++ "differs from file name" +++ namebody
|
||||
case imps of
|
||||
_ | elem name (map (snd . fst . fst) ds) -> return ds --- file already read
|
||||
[] -> return $ (((typ,name),[]),p):ds
|
||||
_ -> do
|
||||
let files = map (gfFile . fst) imps
|
||||
foldM get ((((typ,name),imps),p):ds) files
|
||||
tryRead name = do
|
||||
file <- do
|
||||
let file_gf = gfFile name
|
||||
b <- doesFileExistPath ps file_gf -- try gf file first
|
||||
if b then return file_gf else do
|
||||
let file_gfr = gfrFile name
|
||||
bb <- doesFileExistPath ps file_gfr -- gfr file next
|
||||
if bb then return file_gfr else do
|
||||
return (gfcFile name) -- gfc next
|
||||
|
||||
readFileIfPath ps $ file
|
||||
|
||||
|
||||
|
||||
-- internal module dep information
|
||||
|
||||
data ModUse =
|
||||
MUReuse
|
||||
| MUInstance
|
||||
| MUComplete
|
||||
| MUOther
|
||||
deriving (Eq,Show)
|
||||
|
||||
data ModTyp =
|
||||
MTyResource
|
||||
| MTyIncomplete
|
||||
| MTyIncResource -- interface, incomplete resource
|
||||
| MTyOther
|
||||
deriving (Eq,Show)
|
||||
|
||||
type ModuleHeader = ((ModTyp,ModName),[(ModName,ModUse)])
|
||||
|
||||
importsOfFile :: String -> ModuleHeader
|
||||
importsOfFile =
|
||||
getModuleHeader . -- analyse into mod header
|
||||
filter (not . spec) . -- ignore keywords and special symbols
|
||||
unqual . -- take away qualifiers
|
||||
unrestr . -- take away union restrictions
|
||||
takeWhile (not . term) . -- read until curly or semic
|
||||
lexs . -- analyse into lexical tokens
|
||||
unComm -- ignore comments before the headed line
|
||||
where
|
||||
term = flip elem ["{",";"]
|
||||
spec = flip elem ["of", "open","in",":", "->","=", "-","(", ")",",","**","union"]
|
||||
unqual ws = case ws of
|
||||
"(":q:ws' -> unqual ws'
|
||||
w:ws' -> w:unqual ws'
|
||||
_ -> ws
|
||||
unrestr ws = case ws of
|
||||
"[":ws' -> unrestr $ tail $ dropWhile (/="]") ws'
|
||||
w:ws' -> w:unrestr ws'
|
||||
_ -> ws
|
||||
|
||||
getModuleHeader :: [String] -> ModuleHeader -- with, reuse
|
||||
getModuleHeader ws = case ws of
|
||||
"incomplete":ws2 -> let ((ty,name),us) = getModuleHeader ws2 in
|
||||
case ty of
|
||||
MTyResource -> ((MTyIncResource,name),us)
|
||||
_ -> ((MTyIncomplete,name),us)
|
||||
"interface":ws2 -> let ((_,name),us) = getModuleHeader ("resource":ws2) in
|
||||
((MTyIncResource,name),us)
|
||||
|
||||
"resource":name:ws2 -> case ws2 of
|
||||
"reuse":m:_ -> ((MTyResource,name),[(m,MUReuse)])
|
||||
m:"with":ms -> ((MTyResource,name),(m,MUOther):[(n,MUComplete) | n <- ms])
|
||||
ms -> ((MTyResource,name),[(n,MUOther) | n <- ms])
|
||||
|
||||
"instance":name:m:ws2 -> case ws2 of
|
||||
"reuse":n:_ -> ((MTyResource,name),(m,MUInstance):[(n,MUReuse)])
|
||||
n:"with":ms ->
|
||||
((MTyResource,name),(m,MUInstance):(n,MUComplete):[(n,MUOther) | n <- ms])
|
||||
ms -> ((MTyResource,name),(m,MUInstance):[(n,MUOther) | n <- ms])
|
||||
|
||||
"concrete":name:a:ws2 -> case span (/= "with") ws2 of
|
||||
|
||||
(es,_:ms) -> ((MTyOther,name),
|
||||
[(m,MUOther) | m <- es] ++
|
||||
[(n,MUComplete) | n <- ms])
|
||||
--- m:"with":ms -> ((MTyOther,name),(m,MUOther):[(n,MUComplete) | n <- ms])
|
||||
(ms,[]) -> ((MTyOther,name),[(n,MUOther) | n <- a:ms])
|
||||
|
||||
_:name:ws2 -> case ws2 of
|
||||
"reuse":m:_ -> ((MTyOther,name),[(m,MUReuse)])
|
||||
---- m:n:"with":ms ->
|
||||
---- ((MTyOther,name),(m,MUInstance):(n,MUOther):[(n,MUComplete) | n <- ms])
|
||||
m:"with":ms -> ((MTyOther,name),(m,MUOther):[(n,MUComplete) | n <- ms])
|
||||
ms -> ((MTyOther,name),[(n,MUOther) | n <- ms])
|
||||
_ -> error "the file is empty"
|
||||
|
||||
unComm s = case s of
|
||||
'-':'-':cs -> unComm $ dropWhile (/='\n') cs
|
||||
'{':'-':cs -> dpComm cs
|
||||
c:cs -> c : unComm cs
|
||||
_ -> s
|
||||
|
||||
dpComm s = case s of
|
||||
'-':'}':cs -> unComm cs
|
||||
c:cs -> dpComm cs
|
||||
_ -> s
|
||||
|
||||
lexs s = x:xs where
|
||||
(x,y) = head $ lex s
|
||||
xs = if null y then [] else lexs y
|
||||
|
||||
-- | options can be passed to the compiler by comments in @--#@, in the main file
|
||||
getOptionsFromFile :: FilePath -> IO Options
|
||||
getOptionsFromFile file = do
|
||||
s <- readFileIfStrict file
|
||||
let ls = filter (isPrefixOf "--#") $ lines s
|
||||
return $ fst $ getOptions "-" $ map (unwords . words . drop 3) ls
|
||||
|
||||
-- | check if old GF file
|
||||
isOldFile :: FilePath -> IO Bool
|
||||
isOldFile f = do
|
||||
s <- readFileIfStrict f
|
||||
let s' = unComm s
|
||||
return $ not (null s') && old (head (words s'))
|
||||
where
|
||||
old = flip elem $ words
|
||||
"cat category data def flags fun include lin lincat lindef lintype oper param pattern printname rule"
|
||||
|
||||
|
||||
|
||||
-- | old GF tolerated newlines in quotes. No more supported!
|
||||
fixNewlines :: String -> String
|
||||
fixNewlines s = case s of
|
||||
'"':cs -> '"':mk cs
|
||||
c :cs -> c:fixNewlines cs
|
||||
_ -> s
|
||||
where
|
||||
mk s = case s of
|
||||
'\\':'"':cs -> '\\':'"': mk cs
|
||||
'"' :cs -> '"' :fixNewlines cs
|
||||
'\n' :cs -> '\\':'n': mk cs
|
||||
c :cs -> c : mk cs
|
||||
_ -> s
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user