Founding the newly structured GF2.0 cvs archive.

2026-04-29 22:42:52 -06:00 · 2003-09-22 13:16:55 +00:00
commit b1402e8bd6
162 changed files with 25569 additions and 0 deletions
--- a/src/GF/Infra/CheckM.hs
+++ 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
--- a/src/GF/Infra/Ident.hs
+++ 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"))
+
+-}
--- a/src/GF/Infra/Modules.hs
+++ 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
--- a/src/GF/Infra/Option.hs
+++ 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
--- a/src/GF/Infra/ReadFiles.hs
+++ 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 
+
--- a/src/GF/Infra/UseIO.hs
+++ 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
+