summaryrefslogtreecommitdiff
path: root/src/GF/Infra
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF/Infra')
-rw-r--r--src/GF/Infra/CheckM.hs70
-rw-r--r--src/GF/Infra/Ident.hs117
-rw-r--r--src/GF/Infra/Modules.hs181
-rw-r--r--src/GF/Infra/Option.hs204
-rw-r--r--src/GF/Infra/ReadFiles.hs135
-rw-r--r--src/GF/Infra/UseIO.hs245
6 files changed, 952 insertions, 0 deletions
diff --git a/src/GF/Infra/CheckM.hs b/src/GF/Infra/CheckM.hs
new file mode 100644
index 000000000..2ce1a4e95
--- /dev/null
+++ b/src/GF/Infra/CheckM.hs
@@ -0,0 +1,70 @@
+module CheckM where
+
+import Operations
+import Grammar
+import Ident
+import PrGrammar
+
+-- the strings are non-fatal warnings
+type Check a = STM (Context,[String]) a
+
+checkError :: String -> Check a
+checkError = raise
+
+checkCond :: String -> Bool -> Check ()
+checkCond s b = if b then return () else checkError s
+
+-- warnings should be reversed in the end
+checkWarn :: String -> Check ()
+checkWarn s = updateSTM (\ (cont,msg) -> (cont, s:msg))
+
+checkUpdate :: Decl -> Check ()
+checkUpdate d = updateSTM (\ (cont,msg) -> (d:cont, msg))
+
+checkInContext :: [Decl] -> Check r -> Check r
+checkInContext g ch = do
+ i <- checkUpdates g
+ r <- ch
+ checkResets i
+ return r
+
+checkUpdates :: [Decl] -> Check Int
+checkUpdates ds = mapM checkUpdate ds >> return (length ds)
+
+checkReset :: Check ()
+checkReset = checkResets 1
+
+checkResets :: Int -> Check ()
+checkResets i = updateSTM (\ (cont,msg) -> (drop i cont, msg))
+
+checkGetContext :: Check Context
+checkGetContext = do
+ (co,_) <- readSTM
+ return co
+
+checkLookup :: Ident -> Check Type
+checkLookup x = do
+ co <- checkGetContext
+ checkErr $ maybe (prtBad "unknown variable" x) return $ lookup x co
+
+checkStart :: Check a -> Err (a,(Context,[String]))
+checkStart c = appSTM c ([],[])
+
+checkErr :: Err a -> Check a
+checkErr e = stm (\s -> do
+ v <- e
+ return (v,s)
+ )
+
+checkVal :: a -> Check a
+checkVal v = return v
+
+prtFail :: Print a => String -> a -> Check b
+prtFail s t = checkErr $ prtBad s t
+
+checkIn :: String -> Check a -> Check a
+checkIn msg c = stm $ \s@(g,ws) -> case appSTM c s of
+ Bad e -> Bad $ msg ++++ e
+ Ok (v,(g',ws')) -> Ok (v,(g',ws2)) where
+ new = take (length ws' - length ws) ws'
+ ws2 = [msg ++++ w | w <- new] ++ ws
diff --git a/src/GF/Infra/Ident.hs b/src/GF/Infra/Ident.hs
new file mode 100644
index 000000000..3e564460c
--- /dev/null
+++ b/src/GF/Infra/Ident.hs
@@ -0,0 +1,117 @@
+module Ident where
+
+import Operations
+-- import Monad
+
+data Ident =
+ IC String -- raw identifier after parsing, resolved in Rename
+ | IW -- wildcard
+
+-- below this line: internal representation never returned by the parser
+ | IV (Int,String) -- variable
+ | IA (String,Int) -- argument of cat at position
+ | IAV (String,Int,Int) -- argument of cat with bindings at position
+
+ deriving (Eq, Ord, Show, Read)
+
+prIdent :: Ident -> String
+prIdent i = case i of
+ IC s -> s
+ IV (n,s) -> s ++ "_" ++ show n
+ IA (s,j) -> s ++ "_" ++ show j
+ IAV (s,b,j) -> s ++ "_" ++ show b ++ "_" ++ show j
+ IW -> "_"
+
+(identC, identV, identA, identAV, identW) =
+ (IC, IV, IA, IAV, IW)
+
+-- normal identifier
+-- ident s = IC s
+
+-- to mark argument variables
+argIdent 0 (IC c) i = identA (c,i)
+argIdent b (IC c) i = identAV (c,b,i)
+
+-- used in lin defaults
+strVar = identA ("str",0)
+
+-- wild card
+wildIdent = identW
+
+isWildIdent :: Ident -> Bool
+isWildIdent = (== wildIdent)
+
+newIdent = identC "#h"
+
+mkIdent :: String -> Int -> Ident
+mkIdent s i = identV (i,s)
+
+varIndex :: Ident -> Int
+varIndex (IV (n,_)) = n
+varIndex _ = -1 --- other than IV should not count
+
+-- refreshing identifiers
+
+type IdState = ([(Ident,Ident)],Int)
+
+initIdStateN :: Int -> IdState
+initIdStateN i = ([],i)
+
+initIdState :: IdState
+initIdState = initIdStateN 0
+
+lookVar :: Ident -> STM IdState Ident
+lookVar a@(IA _) = return a
+lookVar x = do
+ (sys,_) <- readSTM
+ stm (\s -> maybe (Bad ("cannot find" +++ show x +++ prParenth (show sys)))
+ return $
+ lookup x sys >>= (\y -> return (y,s)))
+
+refVar :: Ident -> STM IdState Ident
+----refVar IW = return IW --- no update of wildcard
+refVar x = do
+ (_,m) <- readSTM
+ let x' = IV (m, prIdent x)
+ updateSTM (\ (sys,mx) -> ((x, x'):sys, mx + 1))
+ return x'
+
+refVarPlus :: Ident -> STM IdState Ident
+----refVarPlus IW = refVar (identC "h")
+refVarPlus x = refVar x
+
+
+{-
+------------------------------
+-- to test
+
+refreshExp :: Exp -> Err Exp
+refreshExp e = err Bad (return . fst) (appSTM (refresh e) initState)
+
+refresh :: Exp -> STM State Exp
+refresh e = case e of
+ Atom x -> lookVar x >>= return . Atom
+ App f a -> liftM2 App (refresh f) (refresh a)
+ Abs x b -> liftM2 Abs (refVar x) (refresh b)
+ Fun xs a b -> do
+ a' <- refresh a
+ xs' <- mapM refVar xs
+ b' <- refresh b
+ return $ Fun xs' a' b'
+
+data Exp =
+ Atom Ident
+ | App Exp Exp
+ | Abs Ident Exp
+ | Fun [Ident] Exp Exp
+ deriving Show
+
+exp1 = Abs (IC "y") (Atom (IC "y"))
+exp2 = Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "y")))
+exp3 = Abs (IC "y") (Abs (IC "z") (App (Atom (IC "y")) (Atom (IC "z"))))
+exp4 = Abs (IC "y") (Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "z"))))
+exp5 = Abs (IC "y") (Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "y"))))
+exp6 = Abs (IC "y") (Fun [IC "x", IC "y"] (Atom (IC "y")) (Atom (IC "y")))
+exp7 = Abs (IL "8") (Atom (IC "y"))
+
+-}
diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs
new file mode 100644
index 000000000..01b789f8f
--- /dev/null
+++ b/src/GF/Infra/Modules.hs
@@ -0,0 +1,181 @@
+module Modules where
+
+import Ident
+import Option
+import Operations
+
+import List
+
+
+-- AR 29/4/2003
+
+-- The same structure will be used in both source code and canonical.
+-- The parameters tell what kind of data is involved.
+-- Invariant: modules are stored in dependency order
+
+data MGrammar i f a = MGrammar {modules :: [(i,ModInfo i f a)]}
+ deriving Show
+
+data ModInfo i f a =
+ ModMainGrammar (MainGrammar i)
+ | ModMod (Module i f a)
+ deriving Show
+
+data Module i f a = Module {
+ mtype :: ModuleType i ,
+ flags :: [f] ,
+ extends :: Maybe i ,
+ opens :: [OpenSpec i] ,
+ jments :: BinTree (i,a)
+ }
+ deriving Show
+
+-- destructive update
+
+--- dep order preserved since old cannot depend on new
+updateMGrammar :: Ord i => MGrammar i f a -> MGrammar i f a -> MGrammar i f a
+updateMGrammar old new = MGrammar $
+ [(i,m) | (i,m) <- os, notElem i (map fst ns)] ++ ns
+ where
+ os = modules old
+ ns = modules new
+
+updateModule :: Ord i => Module i f t -> i -> t -> Module i f t
+updateModule (Module mt fs me ops js) i t =
+ Module mt fs me ops (updateTree (i,t) js)
+
+data MainGrammar i = MainGrammar {
+ mainAbstract :: i ,
+ mainConcretes :: [MainConcreteSpec i]
+ }
+ deriving Show
+
+data MainConcreteSpec i = MainConcreteSpec {
+ concretePrintname :: i ,
+ concreteName :: i ,
+ transferIn :: Maybe (OpenSpec i) , -- if there is an in-transfer
+ transferOut :: Maybe (OpenSpec i) -- if there is an out-transfer
+ }
+ deriving Show
+
+data OpenSpec i = OSimple i | OQualif i i
+ deriving (Eq,Show)
+
+openedModule :: OpenSpec i -> i
+openedModule o = case o of
+ OSimple m -> m
+ OQualif _ m -> m
+
+-- initial dependency list
+depPathModule :: Ord i => Module i f a -> [OpenSpec i]
+depPathModule m = fors m ++ exts m ++ opens m where
+ fors m = case mtype m of
+ MTTransfer i j -> [i,j]
+ MTConcrete i -> [OSimple i]
+ _ -> []
+ exts m = map OSimple $ maybe [] return $ extends m
+
+-- all modules that a module extends, directly or indirectly
+allExtends :: (Show i,Ord i) => MGrammar i f a -> i -> [i]
+allExtends gr i = case lookupModule gr i of
+ Ok (ModMod m) -> case extends m of
+ Just i1 -> i : allExtends gr i1
+ _ -> [i]
+ _ -> []
+
+-- initial search path: the nonqualified dependencies
+searchPathModule :: Ord i => Module i f a -> [i]
+searchPathModule m = [i | OSimple i <- depPathModule m]
+
+-- a new module can safely be added to the end, since nothing old can depend on it
+addModule :: Ord i =>
+ MGrammar i f a -> i -> ModInfo i f a -> MGrammar i f a
+addModule gr name mi = MGrammar $ (modules gr ++ [(name,mi)])
+
+emptyMGrammar :: MGrammar i f a
+emptyMGrammar = MGrammar []
+
+
+-- we store the module type with the identifier
+
+data IdentM i = IdentM {
+ identM :: i ,
+ typeM :: ModuleType i
+ }
+ deriving (Eq,Show)
+
+-- encoding the type of the module
+data ModuleType i =
+ MTAbstract
+ | MTTransfer (OpenSpec i) (OpenSpec i)
+ | MTResource
+ | MTResourceInt
+ | MTResourceImpl i
+ | MTConcrete i
+ | MTConcreteInt i i
+ | MTConcreteImpl i i i
+ | MTReuse i
+ deriving (Eq,Show)
+
+typeOfModule mi = case mi of
+ ModMod m -> mtype m
+
+isResourceModule mi = case typeOfModule mi of
+ MTResource -> True
+ MTReuse _ -> True
+ MTResourceInt -> True
+ MTResourceImpl _ -> True
+ _ -> False
+
+abstractOfConcrete :: (Show i, Eq i) => MGrammar i f a -> i -> Err i
+abstractOfConcrete gr c = do
+ m <- lookupModule gr c
+ case m of
+ ModMod n -> case mtype n of
+ MTConcrete a -> return a
+ _ -> Bad $ "expected concrete" +++ show c
+ _ -> Bad $ "expected concrete" +++ show c
+
+abstractModOfConcrete :: (Show i, Eq i) =>
+ MGrammar i f a -> i -> Err (Module i f a)
+abstractModOfConcrete gr c = do
+ a <- abstractOfConcrete gr c
+ m <- lookupModule gr a
+ case m of
+ ModMod n -> return n
+ _ -> Bad $ "expected abstract" +++ show c
+
+
+-- the canonical file name
+
+--- canonFileName s = prt s ++ ".gfc"
+
+lookupModule :: (Show i,Eq i) => MGrammar i f a -> i -> Err (ModInfo i f a)
+lookupModule gr m = case lookup m (modules gr) of
+ Just i -> return i
+ _ -> Bad $ "unknown module" +++ show m
+ +++ "among" +++ unwords (map (show . fst) (modules gr)) ---- debug
+
+lookupModuleType :: (Show i,Eq i) => MGrammar i f a -> i -> Err (ModuleType i)
+lookupModuleType gr m = do
+ mi <- lookupModule gr m
+ return $ typeOfModule mi
+
+lookupInfo :: (Show i, Ord i) => Module i f a -> i -> Err a
+lookupInfo mo i = lookupTree show i (jments mo)
+
+isModAbs m = case mtype m of
+ MTAbstract -> True
+ _ -> False
+
+isModRes m = case mtype m of
+ MTResource -> True
+ _ -> False
+
+isModCnc m = case mtype m of
+ MTConcrete _ -> True
+ _ -> False
+
+sameMType m n = case (m,n) of
+ (MTConcrete _, MTConcrete _) -> True
+ _ -> m == n
diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs
new file mode 100644
index 000000000..e81c9cd82
--- /dev/null
+++ b/src/GF/Infra/Option.hs
@@ -0,0 +1,204 @@
+module Option where
+
+import List (partition)
+import Char (isDigit)
+
+-- all kinds of options, to be kept abstract
+
+newtype Option = Opt (String,[String]) deriving (Eq,Show,Read)
+newtype Options = Opts [Option] deriving (Eq,Show,Read)
+
+noOptions :: Options
+noOptions = Opts []
+
+iOpt o = Opt (o,[]) -- simple option -o
+aOpt o a = Opt (o,[a]) -- option with argument -o=a
+iOpts = Opts
+
+oArg s = s -- value of option argument
+
+oElem :: Option -> Options -> Bool
+oElem o (Opts os) = elem o os
+
+type OptFun = String -> Option
+
+getOptVal :: Options -> OptFun -> Maybe String
+getOptVal (Opts os) fopt =
+ case [a | opt@(Opt (o,[a])) <- os, opt == fopt a] of
+ a:_ -> Just a
+ _ -> Nothing
+
+getOptInt :: Options -> OptFun -> Maybe Int
+getOptInt opts f = do
+ s <- getOptVal opts f
+ if (not (null s) && all isDigit s) then return (read s) else Nothing
+
+optIntOrAll :: Options -> OptFun -> [a] -> [a]
+optIntOrAll opts f = case getOptInt opts f of
+ Just i -> take i
+ _ -> id
+
+optIntOrN :: Options -> OptFun -> Int -> Int
+optIntOrN opts f n = case getOptInt opts f of
+ Just i -> i
+ _ -> n
+
+optIntOrOne :: Options -> OptFun -> Int
+optIntOrOne opts f = optIntOrN opts f 1
+
+changeOptVal :: Options -> OptFun -> String -> Options
+changeOptVal os f x =
+ addOption (f x) $ maybe os (\y -> removeOption (f y) os) $ getOptVal os f
+
+addOption :: Option -> Options -> Options
+addOption o (Opts os) = iOpts (o:os)
+
+addOptions (Opts os) os0 = foldr addOption os0 os
+
+removeOption :: Option -> Options -> Options
+removeOption o (Opts os) = iOpts (filter (/=o) os)
+
+removeOptions (Opts os) os0 = foldr removeOption os0 os
+
+options = foldr addOption noOptions
+
+unionOptions :: Options -> Options -> Options
+unionOptions (Opts os) (Opts os') = Opts (os ++ os')
+
+-- parsing options, with prefix pre (e.g. "-")
+
+getOptions :: String -> [String] -> (Options, [String])
+getOptions pre inp = let
+ (os,rest) = span (isOption pre) inp -- options before args
+ in
+ (Opts (map (pOption pre) os), rest)
+
+pOption :: String -> String -> Option
+pOption pre s = case span (/= '=') (drop (length pre) s) of
+ (f,_:a) -> aOpt f a
+ (o,[]) -> iOpt o
+
+isOption :: String -> String -> Bool
+isOption pre = (==pre) . take (length pre)
+
+-- printing options, without prefix
+
+prOpt (Opt (s,[])) = s
+prOpt (Opt (s,xs)) = s ++ "=" ++ concat xs
+prOpts (Opts os) = unwords $ map prOpt os
+
+-- a suggestion for option names
+
+-- parsing
+strictParse = iOpt "strict"
+forgiveParse = iOpt "n"
+ignoreParse = iOpt "ign"
+literalParse = iOpt "lit"
+rawParse = iOpt "raw"
+firstParse = iOpt "1"
+dontParse = iOpt "read" -- parse as term instead of string
+
+-- grammar formats
+showAbstr = iOpt "abs"
+showXML = iOpt "xml"
+showOld = iOpt "old"
+showLatex = iOpt "latex"
+showFullForm = iOpt "fullform"
+showEBNF = iOpt "ebnf"
+showCF = iOpt "cf"
+showWords = iOpt "ws"
+showOpts = iOpt "opts"
+-- showOptim = iOpt "opt"
+isCompiled = iOpt "gfc"
+isHaskell = iOpt "gfhs"
+noCompOpers = iOpt "nocomp"
+retainOpers = iOpt "retain"
+defaultGrOpts = []
+newParser = iOpt "new"
+noCF = iOpt "nocf"
+checkCirc = iOpt "nocirc"
+noCheckCirc = iOpt "nocheckcirc"
+
+-- linearization
+allLin = iOpt "all"
+firstLin = iOpt "one"
+distinctLin = iOpt "nub"
+dontLin = iOpt "show"
+showRecord = iOpt "record"
+showStruct = iOpt "structured"
+xmlLin = showXML
+latexLin = showLatex
+tableLin = iOpt "table"
+defaultLinOpts = [firstLin]
+useUTF8 = iOpt "utf8"
+
+-- other
+beVerbose = iOpt "v"
+showInfo = iOpt "i"
+beSilent = iOpt "s"
+emitCode = iOpt "o"
+makeMulti = iOpt "multi"
+beShort = iOpt "short"
+wholeGrammar = iOpt "w"
+makeFudget = iOpt "f"
+byLines = iOpt "lines"
+byWords = iOpt "words"
+analMorpho = iOpt "morpho"
+doTrace = iOpt "tr"
+noCPU = iOpt "nocpu"
+doCompute = iOpt "c"
+optimizeCanon = iOpt "opt"
+
+-- mainly for stand-alone
+useUnicode = iOpt "unicode"
+optCompute = iOpt "compute"
+optCheck = iOpt "typecheck"
+optParaphrase = iOpt "paraphrase"
+forJava = iOpt "java"
+
+-- for edit session
+allLangs = iOpt "All"
+absView = iOpt "Abs"
+
+-- options that take arguments
+useTokenizer = aOpt "lexer"
+useUntokenizer = aOpt "unlexer"
+useParser = aOpt "parser"
+firstCat = aOpt "cat" -- used on command line
+gStartCat = aOpt "startcat" -- used in grammar, to avoid clash w res word
+useLanguage = aOpt "lang"
+speechLanguage = aOpt "language"
+useFont = aOpt "font"
+grammarFormat = aOpt "format"
+grammarPrinter = aOpt "printer"
+filterString = aOpt "filter"
+termCommand = aOpt "transform"
+transferFun = aOpt "transfer"
+forForms = aOpt "forms"
+menuDisplay = aOpt "menu"
+sizeDisplay = aOpt "size"
+typeDisplay = aOpt "types"
+noDepTypes = aOpt "nodeptypes"
+extractGr = aOpt "extract"
+pathList = aOpt "path"
+
+-- refinement order
+nextRefine = aOpt "nextrefine"
+firstRefine = oArg "first"
+lastRefine = oArg "last"
+
+-- Boolean flags
+flagYes = oArg "yes"
+flagNo = oArg "no"
+
+-- integer flags
+flagDepth = aOpt "depth"
+flagLength = aOpt "length"
+flagNumber = aOpt "number"
+
+caseYesNo :: Options -> OptFun -> Maybe Bool
+caseYesNo opts f = do
+ v <- getOptVal opts f
+ if v == flagYes then return True
+ else if v == flagNo then return False
+ else Nothing
diff --git a/src/GF/Infra/ReadFiles.hs b/src/GF/Infra/ReadFiles.hs
new file mode 100644
index 000000000..f755397f2
--- /dev/null
+++ b/src/GF/Infra/ReadFiles.hs
@@ -0,0 +1,135 @@
+module ReadFiles where
+
+import Arch (selectLater, modifiedFiles, ModTime)
+
+import Operations
+import UseIO
+import System
+import Char
+import Monad
+
+-- make analysis for GF grammar modules. AR 11/6/2003
+
+-- 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.
+
+type ModName = String
+type FileName = String
+type InitPath = String
+type FullPath = String
+
+getAllFiles :: [InitPath] -> [(FullPath,ModTime)] -> FileName ->
+ IOE [FullPath]
+getAllFiles ps env file = do
+ ds <- getImports ps file
+ -- print ds ---- debug
+ ds1 <- ioeErr $ either
+ return
+ (\ms -> Bad $ "circular modules" +++ unwords (map show (head ms))) $
+ topoTest $ map fst ds
+ let paths = [(f,p) | ((f,_),p) <- ds]
+ let pds1 = [(p,f) | f <- ds1, Just p <- [lookup f paths]]
+ ds2 <- ioeIO $ mapM selectFormat pds1
+ -- print ds2 ---- debug
+ let ds3 = needCompile ds ds2
+ ds4 <- ioeIO $ modifiedFiles env ds3
+ return ds4
+
+getImports :: [InitPath] -> FileName -> IOE [((ModName,[ModName]),InitPath)]
+getImports ps = get [] where
+ get ds file = do
+ let name = fileBody file
+ (p,s) <- readFileIfPath ps $ file
+ let imps = importsOfFile s
+ case imps of
+ _ | elem name (map (fst . fst) ds) -> return ds --- file already read
+ [] -> return $ ((name,[]),p):ds
+ _ -> do
+ let files = map gfFile imps
+ foldM get (((name,imps),p):ds) files
+
+-- to decide whether to read gf or gfc; returns full file path
+
+selectFormat :: (InitPath,ModName) -> IO (ModName,(FullPath,Bool))
+selectFormat (p,f) = do
+ let pf = prefixPathName p f
+ f0 <- selectLater (gfFile pf) (gfcFile pf)
+ f1 <- selectLater (gfrFile pf) f0
+ return $ (f, (f1, f1 == gfFile pf)) -- True if needs compile
+
+needCompile :: [((ModName,[ModName]),InitPath)] -> [(ModName,(FullPath,Bool))] ->
+ [FullPath]
+needCompile deps sfiles = filt $ mark $ iter changed where
+
+ -- start with the changed files themselves; returns [ModName]
+ changed = [f | (f,(_,True)) <- sfiles]
+
+ -- 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, choose source file if change is needed
+ -- returns [FullPath]
+ mark cs = [f' | (f,(file,_)) <- sfiles,
+ let f' = if (elem f cs) then gfFile (fileBody file) else file]
+
+ -- if the top file is gfc, only gfc files need be read (could be even better)---
+ filt ds = if isGFC (last ds)
+ then [gfcFile name | f <- ds,
+ let (name,suff) = nameAndSuffix f, elem suff ["gfc","gfr"]]
+ else ds
+
+isGFC = (== "gfc") . fileSuffix
+
+gfcFile = suffixFile "gfc"
+gfrFile = suffixFile "gfr"
+gfFile = suffixFile "gf"
+
+-- to get imports without parsing the file
+
+importsOfFile :: String -> [FilePath]
+importsOfFile =
+ filter (not . spec) . -- ignore keywords and special symbols
+ unqual . -- take away qualifiers
+ takeWhile (not . term) . -- read until curly or semic
+ drop 2 . -- ignore keyword and module name
+ lexs . -- analyse into lexical tokens
+ unComm -- ignore comments before the headed line
+ where
+ term = flip elem ["{",";"]
+ spec = flip elem ["of", "open","in", "reuse", "=", "(", ")",",","**"]
+ unqual ws = case ws of
+ "(":q:ws' -> unqual ws'
+ w:ws' -> w:unqual ws'
+ _ -> ws
+
+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
+
+-- old GF tolerated newlines in quotes. No more supported!
+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
+
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 07:18:57 +0000