GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3

10 files changed, 1970 insertions, 0 deletions

diff --git a/src-3.0/GF/Infra/CheckM.hs b/src-3.0/GF/Infra/CheckM.hs
new file mode 100644
index 000000000..251ed2b8b
--- /dev/null
+++ b/src-3.0/GF/Infra/CheckM.hs
@@ -0,0 +1,89 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : CheckM
+-- Maintainer  : (Maintainer)
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:22:33 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.5 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Infra.CheckM (Check,
+	       checkError, checkCond, checkWarn, checkUpdate, checkInContext,
+	       checkUpdates, checkReset, checkResets, checkGetContext, 
+	       checkLookup, checkStart, checkErr, checkVal, checkIn, 
+	       prtFail
+	      ) where
+
+import GF.Data.Operations
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Grammar.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-3.0/GF/Infra/Comments.hs b/src-3.0/GF/Infra/Comments.hs
new file mode 100644
index 000000000..0126db468
--- /dev/null
+++ b/src-3.0/GF/Infra/Comments.hs
@@ -0,0 +1,43 @@
+----------------------------------------------------------------------
+-- |
+-- 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
diff --git a/src-3.0/GF/Infra/CompactPrint.hs b/src-3.0/GF/Infra/CompactPrint.hs
new file mode 100644
index 000000000..486c9e183
--- /dev/null
+++ b/src-3.0/GF/Infra/CompactPrint.hs
@@ -0,0 +1,22 @@
+module GF.Infra.CompactPrint where
+import Data.Char
+
+compactPrint = compactPrintCustom keywordGF (const False)
+
+compactPrintGFCC = compactPrintCustom (const False) keywordGFCC
+
+compactPrintCustom pre post = dps . concat . map (spaceIf pre post) . words 
+
+dps = dropWhile isSpace
+
+spaceIf pre post w = case w of
+  _ | pre w -> "\n" ++ w
+  _ | post w -> w ++ "\n"
+  c:_ | isAlpha c || isDigit c -> " " ++ w
+  '_':_  -> " " ++ w
+  _ -> w
+
+keywordGF w = elem w ["cat","fun","lin","lincat","lindef","oper","param"]
+keywordGFCC w = 
+  last w == ';' || 
+  elem w ["flags","fun","cat","lin","oper","lincat","lindef","printname","param"]
diff --git a/src-3.0/GF/Infra/Ident.hs b/src-3.0/GF/Infra/Ident.hs
new file mode 100644
index 000000000..5ed860990
--- /dev/null
+++ b/src-3.0/GF/Infra/Ident.hs
@@ -0,0 +1,155 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Ident
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/15 11:43:33 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.8 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Infra.Ident (-- * Identifiers
+	      Ident(..), prIdent,
+	      identC, identV, identA, identAV, identW,
+	      argIdent, strVar, wildIdent, isWildIdent,
+	      newIdent, mkIdent, varIndex,
+	      -- * refreshing identifiers
+	      IdState, initIdStateN, initIdState,
+	      lookVar, refVar, refVarPlus
+	     ) where
+
+import GF.Data.Operations
+-- import Monad
+
+
+-- | the constructors labelled /INTERNAL/ are
+-- internal representation never returned by the parser
+data Ident = 
+   IC String            -- ^ raw identifier after parsing, resolved in Rename
+ | IW                   -- ^ wildcard
+--
+-- below this constructor: internal representation never returned by the parser
+ | IV (Int,String)      -- ^ /INTERNAL/ variable
+ | IA (String,Int)      -- ^ /INTERNAL/ argument of cat at position
+ | IAV (String,Int,Int) -- ^ /INTERNAL/ 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 :: String -> Ident
+identV :: (Int, String) -> Ident
+identA :: (String, Int) -> Ident
+identAV:: (String, Int, Int) -> Ident
+identW :: Ident
+(identC, identV, identA, identAV, identW) = 
+    (IC,     IV,     IA,     IAV,     IW)
+
+-- normal identifier
+-- ident s = IC s
+
+-- | to mark argument variables
+argIdent :: Int -> Ident -> Int -> Ident
+argIdent 0 (IC c) i = identA  (c,i)
+argIdent b (IC c) i = identAV (c,b,i)
+
+-- | used in lin defaults
+strVar :: Ident
+strVar = identA ("str",0)
+
+-- | wild card
+wildIdent :: Ident
+wildIdent = identW
+
+isWildIdent :: Ident -> Bool
+isWildIdent x = case x of
+  IW -> True
+  IC "_" -> True
+  _ -> False
+
+newIdent :: Ident
+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-3.0/GF/Infra/Modules.hs b/src-3.0/GF/Infra/Modules.hs
new file mode 100644
index 000000000..4d50608c6
--- /dev/null
+++ b/src-3.0/GF/Infra/Modules.hs
@@ -0,0 +1,416 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Modules
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/09 15:14:30 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.26 $
+--
+-- Datastructures and functions for modules, common to GF and GFC.
+--
+-- 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
+-----------------------------------------------------------------------------
+
+module GF.Infra.Modules (
+		MGrammar(..), ModInfo(..), Module(..), ModuleType(..),
+		MReuseType(..), MInclude (..),
+		extends, isInherited,inheritAll, 
+                updateMGrammar, updateModule, replaceJudgements, addFlag,
+		addOpenQualif, flagsModule, allFlags, mapModules,
+		MainGrammar(..), MainConcreteSpec(..), OpenSpec(..), OpenQualif(..),
+		oSimple, oQualif,
+		ModuleStatus(..),
+		openedModule, allOpens, depPathModule, allDepsModule, partOfGrammar,
+		allExtends, allExtendSpecs, allExtendsPlus, allExtensions, 
+                searchPathModule, addModule,
+		emptyMGrammar, emptyModInfo, emptyModule,
+		IdentM(..),
+		typeOfModule, abstractOfConcrete, abstractModOfConcrete,
+		lookupModule, lookupModuleType, lookupModMod, lookupInfo,
+		allModMod, isModAbs, isModRes, isModCnc, isModTrans,
+		sameMType, isCompilableModule, isCompleteModule,
+		allAbstracts, greatestAbstract, allResources,
+		greatestResource, allConcretes, allConcreteModules
+	       ) where
+
+import GF.Infra.Ident
+import GF.Infra.Option
+import GF.Data.Operations
+
+import Data.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)
+  | ModWith (Module i f a) (i,MInclude i) [OpenSpec i]
+  deriving Show
+
+data Module i f a = Module {
+    mtype   :: ModuleType i ,
+    mstatus :: ModuleStatus ,
+    flags   :: [f] ,
+    extend  :: [(i,MInclude i)],
+    opens   :: [OpenSpec i] ,
+    jments  :: BinTree i a
+  }
+---  deriving Show
+instance Show (Module i f a) where
+  show _ = "cannot show Module with FiniteMap"
+
+-- | encoding the type of the module
+data ModuleType i = 
+    MTAbstract 
+  | MTTransfer (OpenSpec i) (OpenSpec i) 
+  | MTResource
+  | MTConcrete i
+    -- ^ up to this, also used in GFC. Below, source only.
+  | MTInterface
+  | MTInstance i 
+  | MTReuse (MReuseType i)
+  | MTUnion (ModuleType i) [(i,[i])] -- ^ not meant to be recursive
+  deriving (Eq,Show)
+
+data MReuseType i = MRInterface i | MRInstance i i | MRResource i
+  deriving (Show,Eq)
+
+data MInclude i = MIAll | MIOnly [i] | MIExcept [i]
+  deriving (Show,Eq)
+
+extends :: Module i f a -> [i]
+extends = map fst . extend
+
+isInherited :: Eq i => MInclude i -> i -> Bool
+isInherited c i = case c of
+  MIAll -> True
+  MIOnly is -> elem i is
+  MIExcept is -> notElem i is
+
+inheritAll :: i -> (i,MInclude i)
+inheritAll i = (i,MIAll)
+
+-- 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 ms fs me ops js) i t = 
+  Module mt ms fs me ops (updateTree (i,t) js)
+
+replaceJudgements :: Module i f t -> BinTree i t -> Module i f t
+replaceJudgements (Module mt ms fs me ops _) js = Module mt ms fs me ops js
+
+addOpenQualif :: i -> i -> Module i f t -> Module i f t
+addOpenQualif i j (Module mt ms fs me ops js) = 
+  Module mt ms fs me (oQualif i j : ops) js
+
+addFlag :: f -> Module i f t -> Module i f t
+addFlag f mo = mo {flags = f : flags mo} 
+
+flagsModule :: (i,ModInfo i f a) -> [f]
+flagsModule (_,mi) = case mi of
+  ModMod m -> flags m
+  _ -> []
+
+allFlags :: MGrammar i f a -> [f]
+allFlags gr = concat $ map flags $ [m | (_, ModMod m) <- modules gr]
+
+mapModules :: (Module i f a -> Module i f a) 
+	   -> MGrammar i f a -> MGrammar i f a 
+mapModules f = MGrammar . map (onSnd mapModules') . modules
+    where mapModules' (ModMod m) = ModMod (f m)
+	  mapModules' m = m
+
+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 OpenQualif i 
+ | OQualif OpenQualif i i
+  deriving (Eq,Show)
+
+data OpenQualif =
+   OQNormal
+ | OQInterface
+ | OQIncomplete
+  deriving (Eq,Show)
+
+oSimple :: i -> OpenSpec i
+oSimple = OSimple OQNormal
+
+oQualif :: i -> i -> OpenSpec i
+oQualif = OQualif OQNormal
+
+data ModuleStatus = 
+   MSComplete 
+ | MSIncomplete 
+  deriving (Eq,Show)
+
+openedModule :: OpenSpec i -> i
+openedModule o = case o of
+  OSimple _ m -> m
+  OQualif _ _ m -> m
+
+allOpens :: Module i f a -> [OpenSpec i]
+allOpens m = case mtype m of
+  MTTransfer a b -> a : b : opens m
+  _ -> opens 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]
+    MTInstance i   -> [oSimple i]
+    _              -> []
+  exts m = map oSimple $ extends m
+
+-- | all dependencies
+allDepsModule :: Ord i => MGrammar i f a -> Module i f a -> [OpenSpec i]
+allDepsModule gr m = iterFix add os0 where
+  os0 = depPathModule m
+  add os = [m | o <- os, Just (ModMod n) <- [lookup (openedModule o) mods], 
+                m <- depPathModule n]
+  mods = modules gr
+
+-- | select just those modules that a given one depends on, including itself
+partOfGrammar :: Ord i => MGrammar i f a -> (i,ModInfo i f a) -> MGrammar i f a
+partOfGrammar gr (i,m) = MGrammar [mo | mo@(j,_) <- mods, elem j modsFor] 
+  where
+    mods = modules gr
+    modsFor = case m of
+      ModMod n -> (i:) $ map openedModule $ allDepsModule gr n
+      ---- ModWith n i os -> i : map openedModule os ++ partOfGrammar (ModMod n) ----
+      _ -> [i]
+
+-- | all modules that a module extends, directly or indirectly, without restricts
+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 
+    [] -> [i]
+    is -> i : concatMap (allExtends gr) is
+  _ -> []
+
+-- | all modules that a module extends, directly or indirectly, with restricts
+allExtendSpecs :: (Show i,Ord i) => MGrammar i f a -> i -> [(i,MInclude i)]
+allExtendSpecs gr i = case lookupModule gr i of
+  Ok (ModMod m) -> case extend m of 
+    [] -> [(i,MIAll)]
+    is -> (i,MIAll) : concatMap (allExtendSpecs gr . fst) is
+  _ -> []
+
+-- | this plus that an instance extends its interface
+allExtendsPlus :: (Show i,Ord i) => MGrammar i f a -> i -> [i]
+allExtendsPlus gr i = case lookupModule gr i of
+  Ok (ModMod m) -> i : concatMap (allExtendsPlus gr) (exts m)
+  _ -> []
+ where
+   exts m = extends m ++ [j | MTInstance j <- [mtype m]]
+
+-- | conversely: all modules that extend a given module, incl. instances of interface
+allExtensions :: (Show i,Ord i) => MGrammar i f a -> i -> [i]
+allExtensions gr i = case lookupModule gr i of
+  Ok (ModMod m) -> let es = exts i in es ++ concatMap (allExtensions gr) es
+  _ -> []
+ where
+   exts i = [j | (j,m) <- mods, elem i (extends m) 
+                             || elem (MTInstance i) [mtype m]]
+   mods = [(j,m) | (j,ModMod m) <- modules gr]
+
+-- | 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 []
+
+emptyModInfo :: ModInfo i f a
+emptyModInfo = ModMod emptyModule
+
+emptyModule :: Module i f a
+emptyModule = Module MTResource MSComplete [] [] [] emptyBinTree
+
+-- | we store the module type with the identifier
+data IdentM i = IdentM {
+  identM :: i ,
+  typeM  :: ModuleType i
+  }
+  deriving (Eq,Show)
+
+typeOfModule :: ModInfo i f a -> ModuleType i
+typeOfModule mi = case mi of
+  ModMod m -> mtype m
+
+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
+
+lookupModMod :: (Show i,Eq i) => MGrammar i f a -> i -> Err (Module i f a)
+lookupModMod gr i = do
+  mo <- lookupModule gr i
+  case mo of 
+    ModMod m -> return m
+    _ -> Bad $ "expected proper module, not" +++ show i
+
+lookupInfo :: (Show i, Ord i) => Module i f a -> i -> Err a
+lookupInfo mo i = lookupTree show i (jments mo)
+
+allModMod :: (Show i,Eq i) => MGrammar i f a -> [(i,Module i f a)]
+allModMod gr = [(i,m) | (i, ModMod m) <- modules gr]
+
+isModAbs :: Module i f a -> Bool
+isModAbs m = case mtype m of
+  MTAbstract -> True
+----  MTUnion t -> isModAbs t
+  _ -> False
+
+isModRes :: Module i f a -> Bool
+isModRes m = case mtype m of
+  MTResource -> True
+  MTReuse _ -> True
+----  MTUnion t -> isModRes t --- maybe not needed, since eliminated early
+  MTInterface -> True ---
+  MTInstance _ -> True
+  _ -> False
+
+isModCnc :: Module i f a -> Bool
+isModCnc m = case mtype m of
+  MTConcrete _ -> True
+----  MTUnion t -> isModCnc t
+  _ -> False
+
+isModTrans :: Module i f a -> Bool
+isModTrans m = case mtype m of
+  MTTransfer _ _ -> True
+----  MTUnion t -> isModTrans t
+  _ -> False
+
+sameMType :: Eq i => ModuleType i -> ModuleType i -> Bool
+sameMType m n = case (n,m) of
+  (MTConcrete _, MTConcrete _) -> True
+
+  (MTInstance _, MTInstance _) -> True
+  (MTInstance _, MTResource)   -> True
+  (MTInstance _, MTConcrete _) -> True
+
+  (MTInterface,  MTInstance _) -> True
+  (MTInterface,  MTResource)   -> True    -- for reuse
+  (MTInterface,  MTAbstract)   -> True    -- for reuse
+
+  (MTResource,   MTInstance _) -> True
+  (MTResource,   MTConcrete _) -> True    -- for reuse
+
+  _ -> m == n
+
+-- | don't generate code for interfaces and for incomplete modules
+isCompilableModule :: ModInfo i f a -> Bool
+isCompilableModule m = case m of
+  ModMod m -> case mtype m of
+    MTInterface -> False
+    _ -> mstatus m == MSComplete
+  _ -> False ---
+
+-- | interface and "incomplete M" are not complete
+isCompleteModule :: (Eq i) =>  Module i f a -> Bool
+isCompleteModule m = mstatus m == MSComplete && mtype m /= MTInterface
+
+
+-- | all abstract modules sorted from least to most dependent
+allAbstracts :: Eq i => MGrammar i f a -> [i]
+allAbstracts gr = topoSort 
+  [(i,extends m) | (i,ModMod m) <- modules gr, mtype m == MTAbstract]
+
+-- | the last abstract in dependency order (head of list)
+greatestAbstract :: Eq i => MGrammar i f a -> Maybe i
+greatestAbstract gr = case allAbstracts gr of
+  [] -> Nothing
+  as -> return $ last as
+
+-- | all resource modules
+allResources :: MGrammar i f a -> [i]
+allResources gr = [i | (i,ModMod m) <- modules gr, isModRes m]
+
+-- | the greatest resource in dependency order
+greatestResource :: MGrammar i f a -> Maybe i
+greatestResource gr = case allResources gr of
+  [] -> Nothing
+  a -> return $ head a
+
+-- | all concretes for a given abstract
+allConcretes :: Eq i => MGrammar i f a -> i -> [i]
+allConcretes gr a = 
+  [i | (i, ModMod m) <- modules gr, mtype m == MTConcrete a, isCompleteModule m]
+
+-- | all concrete modules for any abstract
+allConcreteModules :: Eq i => MGrammar i f a -> [i]
+allConcreteModules gr = 
+  [i | (i, ModMod m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]
diff --git a/src-3.0/GF/Infra/Option.hs b/src-3.0/GF/Infra/Option.hs
new file mode 100644
index 000000000..a44cd9db8
--- /dev/null
+++ b/src-3.0/GF/Infra/Option.hs
@@ -0,0 +1,375 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Option
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/14 16:03:41 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.34 $
+--
+-- Options and flags used in GF shell commands and files.
+--
+-- The types 'Option' and 'Options' should be kept abstract, but:
+--
+--   - The constructor 'Opt' is used in "ShellCommands" and "GrammarToSource"
+--
+--   - The constructor 'Opts' us udes in "API", "Shell" and "ShellCommands"
+-----------------------------------------------------------------------------
+
+module GF.Infra.Option where
+
+import Data.List (partition)
+import Data.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 []
+
+-- | simple option -o
+iOpt :: String -> Option
+iOpt o = Opt (o,[])   
+
+-- | option with argument -o=a
+aOpt :: String -> String -> Option
+aOpt o a = Opt (o,[a])  
+
+iOpts :: [Option] -> Options
+iOpts = Opts
+
+-- | value of option argument
+oArg :: String -> String
+oArg s = s 
+
+oElem :: Option -> Options -> Bool
+oElem o (Opts os) = elem o os
+
+eqOpt :: String -> Option -> Bool
+eqOpt s (Opt (o, [])) = s == o
+eqOpt s _ = False
+
+type OptFun = String -> Option
+type OptFunId = String
+
+getOptVal :: Options -> OptFun -> Maybe String
+getOptVal (Opts os) fopt = 
+  case [a | opt@(Opt (o,[a])) <- os, opt == fopt a] of
+    a:_ -> Just a
+    _ -> Nothing
+
+isSetFlag :: Options -> OptFun -> Bool
+isSetFlag (Opts os) fopt = 
+  case [a | opt@(Opt (o,[a])) <- os, opt == fopt a] of
+    a:_ -> True
+    _ -> False
+
+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 :: Options -> Options -> Options
+addOptions (Opts os) os0 = foldr addOption os0 os
+
+concatOptions :: [Options] -> Options
+concatOptions = foldr addOptions noOptions
+
+removeOption :: Option -> Options -> Options
+removeOption o (Opts os) = iOpts (filter (/=o) os)
+
+removeOptions :: Options -> Options -> Options
+removeOptions (Opts os) os0 = foldr removeOption os0 os
+
+options :: [Option] -> Options
+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 :: Option -> String
+prOpt (Opt (s,[])) = s
+prOpt (Opt (s,xs)) = s ++ "=" ++ concat xs
+
+prOpts :: Options -> String
+prOpts (Opts os) = unwords $ map prOpt os
+
+-- * a suggestion for option names
+
+-- ** parsing
+
+strictParse, forgiveParse, ignoreParse, literalParse, rawParse, firstParse :: Option
+-- | parse as term instead of string
+dontParse :: Option
+
+strictParse  = iOpt "strict"
+forgiveParse = iOpt "n"
+ignoreParse  = iOpt "ign"
+literalParse = iOpt "lit"
+rawParse     = iOpt "raw"
+firstParse   = iOpt "1"
+dontParse    = iOpt "read" 
+
+newParser, newerParser, newCParser, newMParser :: Option
+newParser   = iOpt "new"
+newerParser = iOpt "newer"
+newCParser  = iOpt "cfg"
+newMParser  = iOpt "mcfg"
+newFParser  = iOpt "fcfg"
+
+{-
+useParserMCFG, useParserMCFGviaCFG, useParserCFG, useParserCF :: Option
+
+useParserMCFG = iOpt "mcfg"
+useParserMCFGviaCFG = iOpt "mcfg-via-cfg"
+useParserCFG = iOpt "cfg"
+useParserCF = iOpt "cf"
+-}
+
+-- ** grammar formats
+
+showAbstr, showXML, showOld, showLatex, showFullForm,
+  showEBNF, showCF, showWords, showOpts,
+  isCompiled, isHaskell, noCompOpers, retainOpers,
+  noCF, checkCirc, noCheckCirc, lexerByNeed, useUTF8id :: Option
+defaultGrOpts :: [Option]
+
+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 = []
+noCF        = iOpt "nocf"
+checkCirc   = iOpt "nocirc"
+noCheckCirc = iOpt "nocheckcirc"
+lexerByNeed = iOpt "cflexer"
+useUTF8id   = iOpt "utf8id"
+elimSubs    = iOpt "subs"
+
+-- ** linearization
+
+allLin, firstLin, distinctLin, dontLin,
+  showRecord, showStruct, xmlLin, latexLin,
+  tableLin, useUTF8, showLang, withMetas :: Option
+defaultLinOpts :: [Option]
+
+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"
+showLang    = iOpt "lang"
+showDefs    = iOpt "defs"
+withMetas   = iOpt "metas"
+
+-- ** other
+
+beVerbose, showInfo, beSilent, emitCode, getHelp,
+  doMake, doBatch, notEmitCode, makeMulti, beShort,
+  wholeGrammar, makeFudget, byLines, byWords, analMorpho,
+  doTrace, noCPU, doCompute, optimizeCanon, optimizeValues,
+  stripQualif, nostripQualif, showAll, fromSource :: Option
+
+beVerbose    = iOpt "v"
+invertGrep   = iOpt "v" --- same letter in unix
+showInfo     = iOpt "i"
+beSilent     = iOpt "s"
+emitCode     = iOpt "o"
+getHelp      = iOpt "help"
+doMake       = iOpt "make"
+doBatch      = iOpt "batch"
+notEmitCode  = iOpt "noemit"
+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"
+optimizeValues = iOpt "val"
+stripQualif   = iOpt "strip"
+nostripQualif = iOpt "nostrip"
+showAll      = iOpt "all"
+showFields   = iOpt "fields"
+showMulti    = iOpt "multi"
+fromSource   = iOpt "src"
+makeConcrete = iOpt "examples"
+fromExamples = iOpt "ex"
+openEditor   = iOpt "edit"
+getTrees     = iOpt "trees"
+
+-- ** mainly for stand-alone
+
+useUnicode, optCompute, optCheck, optParaphrase, forJava :: Option
+
+useUnicode    = iOpt "unicode"
+optCompute    = iOpt "compute"
+optCheck      = iOpt "typecheck"
+optParaphrase = iOpt "paraphrase"
+forJava       = iOpt "java"
+
+-- ** for edit session
+
+allLangs, absView :: Option
+
+allLangs  = iOpt "All"
+absView   = iOpt "Abs"
+
+-- ** options that take arguments
+
+useTokenizer, useUntokenizer, useParser, withFun, 
+  useLanguage, useResource, speechLanguage, useFont,
+  grammarFormat, grammarPrinter, filterString, termCommand,
+  transferFun, forForms, menuDisplay, sizeDisplay, typeDisplay,
+  noDepTypes, extractGr, pathList, uniCoding :: String -> Option
+-- | used on command line
+firstCat :: String -> Option
+-- | used in grammar, to avoid clash w res word
+gStartCat :: String -> Option
+
+useTokenizer   = aOpt "lexer"
+useUntokenizer = aOpt "unlexer"
+useParser      = aOpt "parser"
+-- useStrategy    = aOpt "strategy" -- parsing strategy
+withFun        = aOpt "fun"
+firstCat       = aOpt "cat"      
+gStartCat      = aOpt "startcat" 
+useLanguage    = aOpt "lang"
+useResource    = aOpt "res"
+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"
+uniCoding      = aOpt "coding"
+probFile       = aOpt "probs"
+noparseFile    = aOpt "noparse"
+usePreprocessor = aOpt "preproc"
+
+-- peb 16/3-05:
+gfcConversion :: String -> Option
+gfcConversion  = aOpt "conversion"
+
+useName, useAbsName, useCncName, useResName, 
+  useFile, useOptimizer :: String -> Option
+
+useName        = aOpt "name"
+useAbsName     = aOpt "abs"
+useCncName     = aOpt "cnc"
+useResName     = aOpt "res"
+useFile        = aOpt "file"
+useOptimizer   = aOpt "optimize"
+
+markLin :: String -> Option
+markOptXML, markOptJava, markOptStruct, markOptFocus :: String
+
+markLin        = aOpt "mark"
+markOptXML     = oArg "xml"
+markOptJava    = oArg "java"
+markOptStruct  = oArg "struct"
+markOptFocus   = oArg "focus"
+
+
+-- ** refinement order
+
+nextRefine :: String -> Option
+firstRefine, lastRefine :: String
+
+nextRefine  = aOpt "nextrefine"
+firstRefine = oArg "first"
+lastRefine  = oArg "last"
+
+-- ** Boolean flags
+
+flagYes, flagNo :: String
+
+flagYes = oArg "yes"
+flagNo  = oArg "no"
+
+-- ** integer flags
+
+flagDepth, flagAlts, flagLength, flagNumber, flagRawtrees :: String -> Option
+
+flagDepth  = aOpt "depth"
+flagAlts   = aOpt "alts"
+flagLength = aOpt "length"
+flagNumber = aOpt "number"
+flagRawtrees = aOpt "rawtrees"
+
+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-3.0/GF/Infra/Print.hs b/src-3.0/GF/Infra/Print.hs
new file mode 100644
index 000000000..17f2c2188
--- /dev/null
+++ b/src-3.0/GF/Infra/Print.hs
@@ -0,0 +1,127 @@
+----------------------------------------------------------------------
+-- |
+-- 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
+
diff --git a/src-3.0/GF/Infra/PrintClass.hs b/src-3.0/GF/Infra/PrintClass.hs
new file mode 100644
index 000000000..5e94984a6
--- /dev/null
+++ b/src-3.0/GF/Infra/PrintClass.hs
@@ -0,0 +1,51 @@
+module GF.Infra.PrintClass where
+
+import Data.List (intersperse)
+
+class Print a where
+    prt :: a -> String
+    prtList :: [a] -> String
+    prtList as = "[" ++ prtSep "," as ++ "]"
+
+prtSep :: Print a => String -> [a] -> String
+prtSep sep = concat . intersperse sep . map prt
+
+prtBefore :: Print a => String -> [a] -> String
+prtBefore before = prtBeforeAfter before ""
+
+prtAfter :: Print a => String -> [a] -> String
+prtAfter after = prtBeforeAfter "" after
+
+prtBeforeAfter :: Print a => String -> String -> [a] -> String
+prtBeforeAfter before after as = concat [ before ++ prt a ++ after | a <- as ]
+
+prtPairList :: (Print a, Print b) => String -> String -> [(a,b)] -> String
+prtPairList comma sep xys = prtSep sep [ prt x ++ comma ++ prt y | (x,y) <- xys ]
+prIO :: Print a => a -> IO ()
+prIO = putStr . prt
+
+instance Print a => Print [a] where
+    prt = prtList
+
+instance (Print a, Print b) => Print (a, b) where
+    prt (a, b) = "(" ++ prt a ++ "," ++ prt b ++ ")"
+
+instance (Print a, Print b, Print c) => Print (a, b, c) where
+    prt (a, b, c) = "(" ++ prt a ++ "," ++ prt b ++ "," ++ prt c ++ ")"
+
+instance (Print a, Print b, Print c, Print d) => Print (a, b, c, d) where
+    prt (a, b, c, d) = "(" ++ prt a ++ "," ++ prt b ++ "," ++ prt c ++ "," ++ prt d ++ ")"
+
+instance Print Char where
+    prt = return
+    prtList = id
+
+instance Print Int where
+    prt = show
+
+instance Print Integer where
+    prt = show
+
+instance Print a => Print (Maybe a) where
+    prt (Just a) = prt a
+    prt Nothing  = "Nothing"
diff --git a/src-3.0/GF/Infra/ReadFiles.hs b/src-3.0/GF/Infra/ReadFiles.hs
new file mode 100644
index 000000000..ce33ec23f
--- /dev/null
+++ b/src-3.0/GF/Infra/ReadFiles.hs
@@ -0,0 +1,362 @@
+----------------------------------------------------------------------
+-- |
+-- 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 
+
diff --git a/src-3.0/GF/Infra/UseIO.hs b/src-3.0/GF/Infra/UseIO.hs
new file mode 100644
index 000000000..4125a0417
--- /dev/null
+++ b/src-3.0/GF/Infra/UseIO.hs
@@ -0,0 +1,330 @@
+{-# 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
+