changed names of resource-1.3; added a note on homepage on release

8 files changed, 1950 insertions, 0 deletions

diff --git a/src/GF/Infra/CheckM.hs b/src/GF/Infra/CheckM.hs
new file mode 100644
index 000000000..251ed2b8b
--- /dev/null
+++ b/src/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/GF/Infra/CompactPrint.hs b/src/GF/Infra/CompactPrint.hs
new file mode 100644
index 000000000..486c9e183
--- /dev/null
+++ b/src/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/GF/Infra/GetOpt.hs b/src/GF/Infra/GetOpt.hs
new file mode 100644
index 000000000..ede561c90
--- /dev/null
+++ b/src/GF/Infra/GetOpt.hs
@@ -0,0 +1,381 @@
+-- This is a version of System.Console.GetOpt which has been hacked to
+-- support long options with a single dash. Since we don't want the annoying
+-- clash with short options that start with the same character as a long
+-- one, we don't allow short options to be given together (e.g. -zxf),
+-- nor do we allow options to be given as any unique prefix.
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Console.GetOpt
+-- Copyright   :  (c) Sven Panne 2002-2005
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+--
+-- This library provides facilities for parsing the command-line options
+-- in a standalone program.  It is essentially a Haskell port of the GNU 
+-- @getopt@ library.
+--
+-----------------------------------------------------------------------------
+
+{-
+Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996 (small
+changes Dec. 1997)
+
+Two rather obscure features are missing: The Bash 2.0 non-option hack
+(if you don't already know it, you probably don't want to hear about
+it...) and the recognition of long options with a single dash
+(e.g. '-help' is recognised as '--help', as long as there is no short
+option 'h').
+
+Other differences between GNU's getopt and this implementation:
+
+* To enforce a coherent description of options and arguments, there
+  are explanation fields in the option/argument descriptor.
+
+* Error messages are now more informative, but no longer POSIX
+  compliant... :-(
+
+And a final Haskell advertisement: The GNU C implementation uses well
+over 1100 lines, we need only 195 here, including a 46 line example! 
+:-)
+-}
+
+--module System.Console.GetOpt (
+module GF.Infra.GetOpt (
+   -- * GetOpt
+   getOpt, getOpt',
+   usageInfo,
+   ArgOrder(..),
+   OptDescr(..),
+   ArgDescr(..),
+
+   -- * Examples
+
+   -- |To hopefully illuminate the role of the different data structures,
+   -- here are the command-line options for a (very simple) compiler,
+   -- done in two different ways.
+   -- The difference arises because the type of 'getOpt' is
+   -- parameterized by the type of values derived from flags.
+
+   -- ** Interpreting flags as concrete values
+   -- $example1
+
+   -- ** Interpreting flags as transformations of an options record
+   -- $example2
+) where
+
+import Prelude -- necessary to get dependencies right
+
+import Data.List ( isPrefixOf, find )
+
+-- |What to do with options following non-options
+data ArgOrder a
+  = RequireOrder                -- ^ no option processing after first non-option
+  | Permute                     -- ^ freely intersperse options and non-options
+  | ReturnInOrder (String -> a) -- ^ wrap non-options into options
+
+{-|
+Each 'OptDescr' describes a single option.
+
+The arguments to 'Option' are:
+
+* list of short option characters
+
+* list of long option strings (without \"--\")
+
+* argument descriptor
+
+* explanation of option for user
+-}
+data OptDescr a =              -- description of a single options:
+   Option [Char]                --    list of short option characters
+          [String]              --    list of long option strings (without "--")
+          (ArgDescr a)          --    argument descriptor
+          String                --    explanation of option for user
+
+-- |Describes whether an option takes an argument or not, and if so
+-- how the argument is injected into a value of type @a@.
+data ArgDescr a
+   = NoArg                   a         -- ^   no argument expected
+   | ReqArg (String       -> a) String -- ^   option requires argument
+   | OptArg (Maybe String -> a) String -- ^   optional argument
+
+data OptKind a                -- kind of cmd line arg (internal use only):
+   = Opt       a                --    an option
+   | UnreqOpt  String           --    an un-recognized option
+   | NonOpt    String           --    a non-option
+   | EndOfOpts                  --    end-of-options marker (i.e. "--")
+   | OptErr    String           --    something went wrong...
+
+-- | Return a string describing the usage of a command, derived from
+-- the header (first argument) and the options described by the 
+-- second argument.
+usageInfo :: String                    -- header
+          -> [OptDescr a]              -- option descriptors
+          -> String                    -- nicely formatted decription of options
+usageInfo header optDescr = unlines (header:table)
+   where (ss,ls,ds)     = (unzip3 . concatMap fmtOpt) optDescr
+         table          = zipWith3 paste (sameLen ss) (sameLen ls) ds
+         paste x y z    = "  " ++ x ++ "  " ++ y ++ "  " ++ z
+         sameLen xs     = flushLeft ((maximum . map length) xs) xs
+         flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ]
+
+fmtOpt :: OptDescr a -> [(String,String,String)]
+fmtOpt (Option sos los ad descr) =
+   case lines descr of
+     []     -> [(sosFmt,losFmt,"")]
+     (d:ds) ->  (sosFmt,losFmt,d) : [ ("","",d') | d' <- ds ]
+   where sepBy _  []     = ""
+         sepBy _  [x]    = x
+         sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs
+         sosFmt = sepBy ',' (map (fmtShort ad) sos)
+         losFmt = sepBy ',' (map (fmtLong  ad) los)
+
+fmtShort :: ArgDescr a -> Char -> String
+fmtShort (NoArg  _   ) so = "-" ++ [so]
+fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad
+fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]"
+
+fmtLong :: ArgDescr a -> String -> String
+fmtLong (NoArg  _   ) lo = "--" ++ lo
+fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad
+fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"
+
+{-|
+Process the command-line, and return the list of values that matched
+(and those that didn\'t). The arguments are:
+
+* The order requirements (see 'ArgOrder')
+
+* The option descriptions (see 'OptDescr')
+
+* The actual command line arguments (presumably got from 
+  'System.Environment.getArgs').
+
+'getOpt' returns a triple consisting of the option arguments, a list
+of non-options, and a list of error messages.
+-}
+getOpt :: ArgOrder a                   -- non-option handling
+       -> [OptDescr a]                 -- option descriptors
+       -> [String]                     -- the command-line arguments
+       -> ([a],[String],[String])      -- (options,non-options,error messages)
+getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us)
+   where (os,xs,us,es) = getOpt' ordering optDescr args
+
+{-|
+This is almost the same as 'getOpt', but returns a quadruple
+consisting of the option arguments, a list of non-options, a list of
+unrecognized options, and a list of error messages.
+-}
+getOpt' :: ArgOrder a                         -- non-option handling
+        -> [OptDescr a]                       -- option descriptors
+        -> [String]                           -- the command-line arguments
+        -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages)
+getOpt' _        _        []         =  ([],[],[],[])
+getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering
+   where procNextOpt (Opt o)      _                 = (o:os,xs,us,es)
+         procNextOpt (UnreqOpt u) _                 = (os,xs,u:us,es)
+         procNextOpt (NonOpt x)   RequireOrder      = ([],x:rest,[],[])
+         procNextOpt (NonOpt x)   Permute           = (os,x:xs,us,es)
+         procNextOpt (NonOpt x)   (ReturnInOrder f) = (f x :os, xs,us,es)
+         procNextOpt EndOfOpts    RequireOrder      = ([],rest,[],[])
+         procNextOpt EndOfOpts    Permute           = ([],rest,[],[])
+         procNextOpt EndOfOpts    (ReturnInOrder f) = (map f rest,[],[],[])
+         procNextOpt (OptErr e)   _                 = (os,xs,us,e:es)
+
+         (opt,rest) = getNext arg args optDescr
+         (os,xs,us,es) = getOpt' ordering optDescr rest
+
+-- take a look at the next cmd line arg and decide what to do with it
+getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
+getNext ('-':'-':[]) rest _        = (EndOfOpts,rest)
+getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr
+getNext ('-'    :xs) rest optDescr = longOpt xs rest optDescr
+getNext a            rest _        = (NonOpt a,rest)
+
+-- handle long option
+longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
+longOpt ls rs optDescr = long ads arg rs
+   where (opt,arg) = break (=='=') ls
+         options   = [ o | o@(Option ss xs _ _) <- optDescr
+                         , opt `elem` map (:[]) ss || opt `elem` xs ]
+         ads       = [ ad | Option _ _ ad _ <- options ]
+         optStr    = ("--"++opt)
+
+         long (_:_:_)      _        rest     = (errAmbig options optStr,rest)
+         long [NoArg  a  ] []       rest     = (Opt a,rest)
+         long [NoArg  _  ] ('=':_)  rest     = (errNoArg optStr,rest)
+         long [ReqArg _ d] []       []       = (errReq d optStr,[])
+         long [ReqArg f _] []       (r:rest) = (Opt (f r),rest)
+         long [ReqArg f _] ('=':xs) rest     = (Opt (f xs),rest)
+         long [OptArg f _] []       rest     = (Opt (f Nothing),rest)
+         long [OptArg f _] ('=':xs) rest     = (Opt (f (Just xs)),rest)
+         long _            _        rest     = (UnreqOpt ("--"++ls),rest)
+
+
+-- miscellaneous error formatting
+
+errAmbig :: [OptDescr a] -> String -> OptKind a
+errAmbig ods optStr = OptErr (usageInfo header ods)
+   where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"
+
+errReq :: String -> String -> OptKind a
+errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")
+
+errUnrec :: String -> String
+errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n"
+
+errNoArg :: String -> OptKind a
+errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")
+
+{-
+-----------------------------------------------------------------------------------------
+-- and here a small and hopefully enlightening example:
+
+data Flag = Verbose | Version | Name String | Output String | Arg String   deriving Show
+
+options :: [OptDescr Flag]
+options =
+   [Option ['v']     ["verbose"]           (NoArg Verbose)      "verbosely list files",
+    Option ['V','?'] ["version","release"] (NoArg Version)      "show version info",
+    Option ['o']     ["output"]            (OptArg out "FILE")  "use FILE for dump",
+    Option ['n']     ["name"]              (ReqArg Name "USER") "only dump USER's files"]
+
+out :: Maybe String -> Flag
+out Nothing  = Output "stdout"
+out (Just o) = Output o
+
+test :: ArgOrder Flag -> [String] -> String
+test order cmdline = case getOpt order options cmdline of
+                        (o,n,[]  ) -> "options=" ++ show o ++ "  args=" ++ show n ++ "\n"
+                        (_,_,errs) -> concat errs ++ usageInfo header options
+   where header = "Usage: foobar [OPTION...] files..."
+
+-- example runs:
+-- putStr (test RequireOrder ["foo","-v"])
+--    ==> options=[]  args=["foo", "-v"]
+-- putStr (test Permute ["foo","-v"])
+--    ==> options=[Verbose]  args=["foo"]
+-- putStr (test (ReturnInOrder Arg) ["foo","-v"])
+--    ==> options=[Arg "foo", Verbose]  args=[]
+-- putStr (test Permute ["foo","--","-v"])
+--    ==> options=[]  args=["foo", "-v"]
+-- putStr (test Permute ["-?o","--name","bar","--na=baz"])
+--    ==> options=[Version, Output "stdout", Name "bar", Name "baz"]  args=[]
+-- putStr (test Permute ["--ver","foo"])
+--    ==> option `--ver' is ambiguous; could be one of:
+--          -v      --verbose             verbosely list files
+--          -V, -?  --version, --release  show version info   
+--        Usage: foobar [OPTION...] files...
+--          -v        --verbose             verbosely list files  
+--          -V, -?    --version, --release  show version info     
+--          -o[FILE]  --output[=FILE]       use FILE for dump     
+--          -n USER   --name=USER           only dump USER's files
+-----------------------------------------------------------------------------------------
+-}
+
+{- $example1
+
+A simple choice for the type associated with flags is to define a type
+@Flag@ as an algebraic type representing the possible flags and their
+arguments:
+
+>    module Opts1 where
+>    
+>    import System.Console.GetOpt
+>    import Data.Maybe ( fromMaybe )
+>    
+>    data Flag 
+>     = Verbose  | Version 
+>     | Input String | Output String | LibDir String
+>       deriving Show
+>    
+>    options :: [OptDescr Flag]
+>    options =
+>     [ Option ['v']     ["verbose"] (NoArg Verbose)       "chatty output on stderr"
+>     , Option ['V','?'] ["version"] (NoArg Version)       "show version number"
+>     , Option ['o']     ["output"]  (OptArg outp "FILE")  "output FILE"
+>     , Option ['c']     []          (OptArg inp  "FILE")  "input FILE"
+>     , Option ['L']     ["libdir"]  (ReqArg LibDir "DIR") "library directory"
+>     ]
+>    
+>    inp,outp :: Maybe String -> Flag
+>    outp = Output . fromMaybe "stdout"
+>    inp  = Input  . fromMaybe "stdin"
+>    
+>    compilerOpts :: [String] -> IO ([Flag], [String])
+>    compilerOpts argv = 
+>       case getOpt Permute options argv of
+>          (o,n,[]  ) -> return (o,n)
+>          (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
+>      where header = "Usage: ic [OPTION...] files..."
+
+Then the rest of the program will use the constructed list of flags
+to determine it\'s behaviour.
+
+-}
+
+{- $example2
+
+A different approach is to group the option values in a record of type
+@Options@, and have each flag yield a function of type
+@Options -> Options@ transforming this record.
+
+>    module Opts2 where
+>
+>    import System.Console.GetOpt
+>    import Data.Maybe ( fromMaybe )
+>
+>    data Options = Options
+>     { optVerbose     :: Bool
+>     , optShowVersion :: Bool
+>     , optOutput      :: Maybe FilePath
+>     , optInput       :: Maybe FilePath
+>     , optLibDirs     :: [FilePath]
+>     } deriving Show
+>
+>    defaultOptions    = Options
+>     { optVerbose     = False
+>     , optShowVersion = False
+>     , optOutput      = Nothing
+>     , optInput       = Nothing
+>     , optLibDirs     = []
+>     }
+>
+>    options :: [OptDescr (Options -> Options)]
+>    options =
+>     [ Option ['v']     ["verbose"]
+>         (NoArg (\ opts -> opts { optVerbose = True }))
+>         "chatty output on stderr"
+>     , Option ['V','?'] ["version"]
+>         (NoArg (\ opts -> opts { optShowVersion = True }))
+>         "show version number"
+>     , Option ['o']     ["output"]
+>         (OptArg ((\ f opts -> opts { optOutput = Just f }) . fromMaybe "output")
+>                 "FILE")
+>         "output FILE"
+>     , Option ['c']     []
+>         (OptArg ((\ f opts -> opts { optInput = Just f }) . fromMaybe "input")
+>                 "FILE")
+>         "input FILE"
+>     , Option ['L']     ["libdir"]
+>         (ReqArg (\ d opts -> opts { optLibDirs = optLibDirs opts ++ [d] }) "DIR")
+>         "library directory"
+>     ]
+>
+>    compilerOpts :: [String] -> IO (Options, [String])
+>    compilerOpts argv =
+>       case getOpt Permute options argv of
+>          (o,n,[]  ) -> return (foldl (flip id) defaultOptions o, n)
+>          (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
+>      where header = "Usage: ic [OPTION...] files..."
+
+Similarly, each flag could yield a monadic function transforming a record,
+of type @Options -> IO Options@ (or any other monad), allowing option
+processing to perform actions of the chosen monad, e.g. printing help or
+version messages, checking that file arguments exist, etc.
+
+-}
diff --git a/src/GF/Infra/Ident.hs b/src/GF/Infra/Ident.hs
new file mode 100644
index 000000000..45ebf3a5b
--- /dev/null
+++ b/src/GF/Infra/Ident.hs
@@ -0,0 +1,152 @@
+----------------------------------------------------------------------
+-- |
+-- 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(..), ident2bs, prIdent,
+	      identC, identV, identA, identAV, identW,
+	      argIdent, varStr, varX, isWildIdent, varIndex,
+	      -- * refreshing identifiers
+	      IdState, initIdStateN, initIdState,
+	      lookVar, refVar, refVarPlus
+	     ) where
+
+import GF.Data.Operations
+import qualified Data.ByteString.Char8 as BS
+-- import Monad
+
+
+-- | the constructors labelled /INTERNAL/ are
+-- internal representation never returned by the parser
+data Ident = 
+   IC  {-# UNPACK #-} !BS.ByteString                                           -- ^ raw identifier after parsing, resolved in Rename
+ | IW                                                                          -- ^ wildcard
+--
+-- below this constructor: internal representation never returned by the parser
+ | IV  {-# UNPACK #-} !BS.ByteString {-# UNPACK #-} !Int                       -- ^ /INTERNAL/ variable
+ | IA  {-# UNPACK #-} !BS.ByteString {-# UNPACK #-} !Int                       -- ^ /INTERNAL/ argument of cat at position
+ | IAV {-# UNPACK #-} !BS.ByteString {-# UNPACK #-} !Int {-# UNPACK #-} !Int   -- ^ /INTERNAL/ argument of cat with bindings at position
+-- 
+
+  deriving (Eq, Ord, Show, Read)
+
+ident2bs :: Ident -> BS.ByteString
+ident2bs i = case i of
+  IC s -> s
+  IV s n -> BS.append s (BS.pack ('_':show n))
+  IA s j -> BS.append s (BS.pack ('_':show j))
+  IAV s b j -> BS.append s (BS.pack ('_':show b ++ '_':show j))
+  IW -> BS.pack "_"
+
+prIdent :: Ident -> String
+prIdent i = BS.unpack $! ident2bs i
+
+identC :: BS.ByteString -> Ident
+identV :: BS.ByteString -> Int -> Ident
+identA :: BS.ByteString -> Int -> Ident
+identAV:: BS.ByteString -> 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
+varStr :: Ident
+varStr = identA (BS.pack "str") 0
+
+-- | refreshing variables
+varX :: Int -> Ident
+varX = identV (BS.pack "x")
+
+isWildIdent :: Ident -> Bool
+isWildIdent x = case x of
+  IW -> True
+  IC s | s == BS.pack "_" -> True
+  _ -> False
+
+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 (ident2bs x) m
+  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..797f729c8
--- /dev/null
+++ b/src/GF/Infra/Modules.hs
@@ -0,0 +1,429 @@
+----------------------------------------------------------------------
+-- |
+-- 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,
+                lookupPosition, showPosition,
+		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 a = MGrammar {modules :: [(i,ModInfo i a)]}
+  deriving Show
+
+data ModInfo i a =
+    ModMainGrammar (MainGrammar i)
+  | ModMod  (Module i a)
+  | ModWith (Module i a) (i,MInclude i) [OpenSpec i]
+  deriving Show
+
+data Module i a = Module {
+    mtype   :: ModuleType i ,
+    mstatus :: ModuleStatus ,
+    flags   :: ModuleOptions,
+    extend  :: [(i,MInclude i)],
+    opens   :: [OpenSpec i] ,
+    jments  :: BinTree i a ,
+    positions :: BinTree i (String,(Int,Int)) -- file, first line, last line
+  }
+---  deriving Show
+instance Show (Module i 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 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 a -> MGrammar i a -> MGrammar i 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 t -> i -> t -> Module i t
+updateModule (Module  mt ms fs me ops js ps) i t = 
+  Module mt ms fs me ops (updateTree (i,t) js) ps
+
+replaceJudgements :: Module i t -> BinTree i t -> Module i t
+replaceJudgements (Module mt ms fs me ops _ ps) js = Module mt ms fs me ops js ps
+
+addOpenQualif :: i -> i -> Module i t -> Module i t
+addOpenQualif i j (Module mt ms fs me ops js ps) = 
+  Module mt ms fs me (oQualif i j : ops) js ps
+
+addFlag :: ModuleOptions -> Module i t -> Module i t
+addFlag f mo = mo {flags = addModuleOptions (flags mo) f} 
+
+flagsModule :: (i,ModInfo i a) -> ModuleOptions
+flagsModule (_,mi) = case mi of
+  ModMod m -> flags m
+  _ -> noModuleOptions
+
+allFlags :: MGrammar i a -> ModuleOptions
+allFlags gr = concatModuleOptions $ map flags $ [m | (_, ModMod m) <- modules gr]
+
+mapModules :: (Module i a -> Module i a) 
+	   -> MGrammar i a -> MGrammar i 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 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 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 a -> Module i 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 a -> (i,ModInfo i a) -> MGrammar i 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 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 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 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 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 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 a -> i -> ModInfo i a -> MGrammar i a
+addModule gr name mi = MGrammar $ (modules gr ++ [(name,mi)])
+
+emptyMGrammar :: MGrammar i a
+emptyMGrammar = MGrammar []
+
+emptyModInfo :: ModInfo i a
+emptyModInfo = ModMod emptyModule
+
+emptyModule :: Module i a
+emptyModule = Module 
+  MTResource MSComplete noModuleOptions [] [] emptyBinTree emptyBinTree
+
+-- | we store the module type with the identifier
+data IdentM i = IdentM {
+  identM :: i ,
+  typeM  :: ModuleType i
+  }
+  deriving (Eq,Show)
+
+typeOfModule :: ModInfo i a -> ModuleType i
+typeOfModule mi = case mi of
+  ModMod m -> mtype m
+
+abstractOfConcrete :: (Show i, Eq i) => MGrammar i 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 a -> i -> Err (Module i 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 a -> i -> Err (ModInfo i 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 a -> i -> Err (ModuleType i)
+lookupModuleType gr m = do
+  mi <- lookupModule gr m
+  return $ typeOfModule mi
+
+lookupModMod :: (Show i,Eq i) => MGrammar i a -> i -> Err (Module i 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 a -> i -> Err a
+lookupInfo mo i = lookupTree show i (jments mo)
+
+lookupPosition :: (Show i, Ord i) => Module i a -> i -> Err (String,(Int,Int))
+lookupPosition mo i = lookupTree show i (positions mo)
+
+showPosition :: (Show i, Ord i) => Module i a -> i -> String
+showPosition mo i = case lookupPosition mo i of
+  Ok (f,(b,e)) | b == e -> "in" +++ f ++ ", line" +++ show b
+  Ok (f,(b,e)) -> "in" +++ f ++ ", lines" +++ show b ++ "-" ++ show e
+  _ -> ""
+
+
+allModMod :: (Show i,Eq i) => MGrammar i a -> [(i,Module i a)]
+allModMod gr = [(i,m) | (i, ModMod m) <- modules gr]
+
+isModAbs :: Module i a -> Bool
+isModAbs m = case mtype m of
+  MTAbstract -> True
+----  MTUnion t -> isModAbs t
+  _ -> False
+
+isModRes :: Module i 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 a -> Bool
+isModCnc m = case mtype m of
+  MTConcrete _ -> True
+----  MTUnion t -> isModCnc t
+  _ -> False
+
+isModTrans :: Module i 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 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 a -> Bool
+isCompleteModule m = mstatus m == MSComplete && mtype m /= MTInterface
+
+
+-- | all abstract modules sorted from least to most dependent
+allAbstracts :: Eq i => MGrammar i 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 a -> Maybe i
+greatestAbstract gr = case allAbstracts gr of
+  [] -> Nothing
+  as -> return $ last as
+
+-- | all resource modules
+allResources :: MGrammar i a -> [i]
+allResources gr = [i | (i,ModMod m) <- modules gr, isModRes m || isModCnc m]
+
+-- | the greatest resource in dependency order
+greatestResource :: MGrammar i a -> Maybe i
+greatestResource gr = case allResources gr of
+  [] -> Nothing
+  a -> return $ head a ---- why not last as in Abstract? works though AR 24/5/2008
+
+-- | all concretes for a given abstract
+allConcretes :: Eq i => MGrammar i 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 a -> [i]
+allConcreteModules gr = 
+  [i | (i, ModMod m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]
diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs
new file mode 100644
index 000000000..380cb3af7
--- /dev/null
+++ b/src/GF/Infra/Option.hs
@@ -0,0 +1,549 @@
+module GF.Infra.Option
+    (
+     -- * Option types
+     Options, ModuleOptions,
+     Flags(..), ModuleFlags(..),
+     Mode(..), Phase(..), Verbosity(..), Encoding(..), OutputFormat(..), 
+     SISRFormat(..), Optimization(..),
+     Dump(..), Printer(..), Recomp(..),
+     -- * Option parsing 
+     parseOptions, parseModuleOptions,
+     -- * Option pretty-printing
+     moduleOptionsGFO,
+     -- * Option manipulation
+     addOptions, concatOptions, noOptions,
+     moduleOptions,
+     addModuleOptions, concatModuleOptions, noModuleOptions,
+     helpMessage,
+     -- * Checking specific options
+     flag, moduleFlag,
+     -- * Setting specific options
+     setOptimization,
+     -- * Convenience methods for checking options    
+     verbAtLeast, dump
+    ) where
+
+import Control.Monad
+import Data.Char (toLower)
+import Data.List
+import Data.Maybe
+import GF.Infra.GetOpt
+--import System.Console.GetOpt
+import System.FilePath
+
+import GF.Data.ErrM
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+
+
+
+usageHeader :: String
+usageHeader = unlines 
+ ["Usage: gfc [OPTIONS] [FILE [...]]",
+  "",
+  "How each FILE is handled depends on the file name suffix:",
+  "",
+  ".gf Normal or old GF source, will be compiled.",
+  ".gfo Compiled GF source, will be loaded as is.",
+  ".gfe Example-based GF source, will be converted to .gf and compiled.",
+  ".ebnf Extended BNF format, will be converted to .gf and compiled.",
+  ".cf Context-free (BNF) format, will be converted to .gf and compiled.",
+  "",
+  "If multiple FILES are given, they must be normal GF source, .gfo or .gfe files.",
+  "For the other input formats, only one file can be given.",
+  "",
+  "Command-line options:"]
+
+
+helpMessage :: String
+helpMessage = usageInfo usageHeader optDescr
+
+
+-- FIXME: do we really want multi-line errors?
+errors :: [String] -> Err a
+errors = fail . unlines
+
+-- Types
+
+data Mode = ModeVersion | ModeHelp | ModeInteractive | ModeCompiler
+  deriving (Show,Eq,Ord)
+
+data Verbosity = Quiet | Normal | Verbose | Debug
+  deriving (Show,Eq,Ord,Enum,Bounded)
+
+data Phase = Preproc | Convert | Compile | Link
+  deriving (Show,Eq,Ord)
+
+data Encoding = UTF_8 | ISO_8859_1 | CP_1251
+  deriving (Show,Eq,Ord)
+
+data OutputFormat = FmtPGF 
+                  | FmtJavaScript 
+                  | FmtHaskell 
+                  | FmtHaskell_GADT 
+                  | FmtBNF
+                  | FmtSRGS_XML 
+                  | FmtSRGS_ABNF 
+                  | FmtJSGF 
+                  | FmtGSL 
+                  | FmtVoiceXML
+                  | FmtSLF
+                  | FmtRegExp
+                  | FmtFA
+  deriving (Eq,Ord)
+
+data SISRFormat = 
+    -- | SISR Working draft 1 April 2003
+    --   <http://www.w3.org/TR/2003/WD-semantic-interpretation-20030401/>
+    SISR_WD20030401    
+  | SISR_1_0
+ deriving (Show,Eq,Ord)
+
+data Optimization = OptStem | OptCSE | OptExpand | OptParametrize | OptValues
+  deriving (Show,Eq,Ord)
+
+data Warning = WarnMissingLincat
+  deriving (Show,Eq,Ord)
+
+data Dump = DumpRebuild | DumpExtend | DumpRename | DumpTypeCheck | DumpRefresh | DumpOptimize | DumpCanon
+  deriving (Show,Eq,Ord)
+
+-- | Pretty-printing options
+data Printer = PrinterStrip -- ^ Remove name qualifiers.
+  deriving (Show,Eq,Ord)
+
+data Recomp = AlwaysRecomp | RecompIfNewer | NeverRecomp
+  deriving (Show,Eq,Ord)
+
+data ModuleFlags = ModuleFlags {
+      optName            :: Maybe String,
+      optAbsName         :: Maybe String,
+      optCncName         :: Maybe String,
+      optResName         :: Maybe String,
+      optPreprocessors   :: [String],
+      optEncoding        :: Encoding,
+      optOptimizations   :: Set Optimization,
+      optLibraryPath     :: [FilePath],
+      optStartCat        :: Maybe String,
+      optSpeechLanguage  :: Maybe String,
+      optLexer           :: Maybe String,
+      optUnlexer         :: Maybe String,
+      optErasing         :: Bool,
+      optBuildParser     :: Bool,
+      optWarnings        :: [Warning],
+      optDump            :: [Dump]
+    }
+  deriving (Show)
+
+data Flags = Flags {
+      optMode            :: Mode,
+      optStopAfterPhase  :: Phase,
+      optVerbosity       :: Verbosity,
+      optShowCPUTime     :: Bool,
+      optEmitGFO         :: Bool,
+      optGFODir          :: FilePath,
+      optOutputFormats   :: [OutputFormat],
+      optSISR            :: Maybe SISRFormat,
+      optOutputFile      :: Maybe FilePath,
+      optOutputDir       :: Maybe FilePath,
+      optRecomp          :: Recomp,
+      optPrinter         :: [Printer],
+      optProb            :: Bool,
+      optRetainResource  :: Bool,
+      optModuleFlags     :: ModuleFlags
+    }
+  deriving (Show)
+
+newtype Options = Options (Flags -> Flags)
+
+instance Show Options where
+    show (Options o) = show (o defaultFlags)
+
+newtype ModuleOptions = ModuleOptions (ModuleFlags -> ModuleFlags)
+
+-- Option parsing
+
+parseOptions :: [String] -> Err (Options, [FilePath])
+parseOptions args 
+    | not (null errs) = errors errs
+    | otherwise = do opts <- liftM concatOptions $ sequence optss
+                     return (opts, files)
+  where (optss, files, errs) = getOpt RequireOrder optDescr args
+
+parseModuleOptions :: [String] -> Err ModuleOptions
+parseModuleOptions args 
+    | not (null errs)  = errors errs
+    | not (null files) = errors $ map ("Non-option among module options: " ++) files
+    | otherwise        = liftM concatModuleOptions $ sequence flags
+  where (flags, files, errs) = getOpt RequireOrder moduleOptDescr args
+
+-- Showing options
+
+-- | Pretty-print the module options that are preserved in .gfo files.
+moduleOptionsGFO :: ModuleOptions -> [(String,String)]
+moduleOptionsGFO (ModuleOptions o) = 
+         maybe [] (\x -> [("language",x)]) (optSpeechLanguage mfs)
+      ++ maybe [] (\x -> [("startcat",x)]) (optStartCat mfs)
+--      ++ maybe [] (\x -> [("coding",  e2s x)]) (Just (optEncoding mfs))
+      ++ (if optErasing mfs then [("erasing","on")] else [])
+  where 
+    mfs = o defaultModuleFlags
+    e2s e = maybe [] id $ lookup e [(s,e) | (e,s) <- encodings]
+
+-- Option manipulation
+
+noOptions :: Options
+noOptions = Options id
+
+addOptions :: Options -- ^ Existing options.
+           -> Options -- ^ Options to add (these take preference).
+           -> Options
+addOptions (Options o1) (Options o2) = Options (o2 . o1)
+
+concatOptions :: [Options] -> Options
+concatOptions = foldr addOptions noOptions
+
+moduleOptions :: ModuleOptions -> Options
+moduleOptions (ModuleOptions f) = Options (\o -> o { optModuleFlags = f (optModuleFlags o) })
+
+addModuleOptions :: ModuleOptions -- ^ Existing options.
+                 -> ModuleOptions -- ^ Options to add (these take preference).
+                 -> ModuleOptions
+addModuleOptions (ModuleOptions o1) (ModuleOptions o2) = ModuleOptions (o2 . o1)
+
+concatModuleOptions :: [ModuleOptions] -> ModuleOptions
+concatModuleOptions = foldr addModuleOptions noModuleOptions
+
+noModuleOptions :: ModuleOptions
+noModuleOptions = ModuleOptions id
+
+flag :: (Flags -> a) -> Options -> a
+flag f (Options o) = f (o defaultFlags)
+
+moduleFlag :: (ModuleFlags -> a) -> Options -> a
+moduleFlag f = flag (f . optModuleFlags)
+
+modifyFlags :: (Flags -> Flags) -> Options
+modifyFlags = Options
+
+modifyModuleFlags :: (ModuleFlags -> ModuleFlags) -> Options
+modifyModuleFlags = moduleOptions . ModuleOptions
+
+
+{-
+
+parseModuleFlags :: Options -> [(String,Maybe String)] -> Err ModuleOptions
+parseModuleFlags opts flags = 
+    mapM (uncurry (findFlag moduleOptDescr)) flags >>= foldM (flip ($)) (optModuleOptions opts)
+
+findFlag :: Monad m => [OptDescr a] -> String -> Maybe String -> m a
+findFlag opts n mv = 
+    case filter (`flagMatches` n) opts of
+      []    -> fail $ "Unknown option: " ++ n
+      [opt] -> flagValue opt n mv
+      _     -> fail $ n ++ " matches multiple options."
+
+flagMatches :: OptDescr a -> String -> Bool
+flagMatches (Option cs ss _ _) n = n `elem` (map (:[]) cs ++ ss)
+
+flagValue :: Monad m => OptDescr a -> String -> Maybe String -> m a
+flagValue (Option _ _ arg _) n mv =
+    case (arg, mv) of
+      (NoArg x,    Nothing) -> return x
+      (NoArg _,    Just _ ) -> fail $ "Option " ++ n ++ " does not take a value."
+      (ReqArg _ _, Nothing) -> fail $ "Option " ++ n ++ " requires a value."
+      (ReqArg f _, Just x ) -> return (f x)
+      (OptArg f _, mx     ) -> return (f mx)
+
+-}
+
+-- Default options
+
+defaultModuleFlags :: ModuleFlags
+defaultModuleFlags = ModuleFlags {
+      optName            = Nothing,
+      optAbsName         = Nothing,
+      optCncName         = Nothing,
+      optResName         = Nothing,
+      optPreprocessors   = [],
+      optEncoding        = ISO_8859_1,
+      optOptimizations   = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize,OptValues],
+      optLibraryPath     = [],
+      optStartCat        = Nothing,
+      optSpeechLanguage  = Nothing,
+      optLexer           = Nothing,
+      optUnlexer         = Nothing,
+      optErasing         = False,
+      optBuildParser     = True,
+      optWarnings        = [],
+      optDump            = []
+    }
+
+defaultFlags :: Flags
+defaultFlags = Flags {
+      optMode            = ModeInteractive,
+      optStopAfterPhase  = Compile,
+      optVerbosity       = Normal,
+      optShowCPUTime     = False,
+      optEmitGFO         = True,
+      optGFODir          = ".",
+      optOutputFormats   = [FmtPGF],
+      optSISR            = Nothing,
+      optOutputFile      = Nothing,
+      optOutputDir       = Nothing,
+      optRecomp          = RecompIfNewer,
+      optPrinter         = [],
+      optProb            = False,
+      optRetainResource  = False,
+      optModuleFlags     = defaultModuleFlags
+    }
+
+-- Option descriptions
+
+moduleOptDescr :: [OptDescr (Err ModuleOptions)]
+moduleOptDescr = 
+    [
+     Option ['n'] ["name"] (ReqArg name "NAME") 
+           (unlines ["Use NAME as the name of the output. This is used in the output file names, ",
+                     "with suffixes depending on the formats, and, when relevant, ",
+                     "internally in the output."]),
+     Option [] ["abs"] (ReqArg absName "NAME")
+            ("Use NAME as the name of the abstract syntax module generated from "
+             ++ "a grammar in GF 1 format."),
+     Option [] ["cnc"] (ReqArg cncName "NAME")
+            ("Use NAME as the name of the concrete syntax module generated from "
+             ++ "a grammar in GF 1 format."),
+     Option [] ["res"] (ReqArg resName "NAME")
+            ("Use NAME as the name of the resource module generated from "
+             ++ "a grammar in GF 1 format."),
+     Option ['i'] [] (ReqArg addLibDir "DIR") "Add DIR to the library search path.",
+     Option [] ["path"] (ReqArg setLibPath "DIR:DIR:...") "Set the library search path.",
+     Option [] ["preproc"] (ReqArg preproc "CMD") 
+                 (unlines ["Use CMD to preprocess input files.",
+                           "Multiple preprocessors can be used by giving this option multiple times."]),
+     Option [] ["coding"] (ReqArg coding "ENCODING") 
+                ("Character encoding of the source grammar, ENCODING = "
+                 ++ concat (intersperse " | " (map fst encodings)) ++ "."),
+     Option [] ["erasing"] (onOff erasing False) "Generate erasing grammar (default off).",
+     Option [] ["parser"] (onOff parser True) "Build parser (default on).",
+     Option [] ["startcat"] (ReqArg startcat "CAT") "Grammar start category.",
+     Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar.",
+     Option [] ["lexer"] (ReqArg lexer "LEXER") "Use lexer LEXER.",
+     Option [] ["unlexer"] (ReqArg unlexer "UNLEXER") "Use unlexer UNLEXER.",
+     Option [] ["optimize"] (ReqArg optimize "OPT") 
+                "Select an optimization package. OPT = all | values | parametrize | none",
+     Option [] ["stem"] (onOff (toggleOptimize OptStem) True) "Perform stem-suffix analysis (default on).",
+     Option [] ["cse"] (onOff (toggleOptimize OptCSE) True) "Perform common sub-expression elimination (default on).",
+     dumpOption "rebuild" DumpRebuild,
+     dumpOption "extend" DumpExtend,
+     dumpOption "rename" DumpRename,
+     dumpOption "tc" DumpTypeCheck,
+     dumpOption "refresh" DumpRefresh,
+     dumpOption "opt" DumpOptimize,
+     dumpOption "canon" DumpCanon
+    ]
+    where
+       name        x = set $ \o -> o { optName = Just x }
+       absName     x = set $ \o -> o { optAbsName = Just x }
+       cncName     x = set $ \o -> o { optCncName = Just x }
+       resName     x = set $ \o -> o { optResName = Just x }
+       addLibDir   x = set $ \o -> o { optLibraryPath = x:optLibraryPath o }
+       setLibPath  x = set $ \o -> o { optLibraryPath = splitInModuleSearchPath x }
+       preproc     x = set $ \o -> o { optPreprocessors = optPreprocessors o ++ [x] }
+       coding      x = case lookup x encodings of
+                         Just c  -> set $ \o -> o { optEncoding = c }
+                         Nothing -> fail $ "Unknown character encoding: " ++ x
+       erasing     x = set $ \o -> o { optErasing = x }
+       parser      x = set $ \o -> o { optBuildParser = x }
+       startcat    x = set $ \o -> o { optStartCat = Just x }
+       language    x = set $ \o -> o { optSpeechLanguage = Just x }
+       lexer       x = set $ \o -> o { optLexer = Just x }
+       unlexer     x = set $ \o -> o { optUnlexer = Just x }
+
+       optimize    x = case lookup x optimizationPackages of
+                         Just p  -> set $ \o -> o { optOptimizations = p }
+                         Nothing -> fail $ "Unknown optimization package: " ++ x
+
+       toggleOptimize x b = set $ setOptimization' x b
+
+       dumpOption s d = Option [] ["dump-"++s] (NoArg (set $ \o -> o { optDump = d:optDump o})) ("Dump output of the " ++ s ++ " phase.")
+
+       set = return . ModuleOptions
+
+optDescr :: [OptDescr (Err Options)]
+optDescr = 
+    [
+     Option ['?','h'] ["help"] (NoArg (mode ModeHelp)) "Show help message.",
+     Option ['V'] ["version"] (NoArg (mode ModeVersion)) "Display GF version number.",
+     Option ['v'] ["verbose"] (OptArg verbosity "N") "Set verbosity (default 1). -v alone is the same as -v 2.",
+     Option ['q','s'] ["quiet"] (NoArg (verbosity (Just "0"))) "Quiet, same as -v 0.",
+     Option [] ["batch"] (NoArg (mode ModeCompiler)) "Run in batch compiler mode.",
+     Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).",
+     Option ['E'] [] (NoArg (phase Preproc)) "Stop after preprocessing (with --preproc).",
+     Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.",
+     Option ['c'] [] (NoArg (phase Compile)) "Stop after compiling to .gfo (default) .",
+     Option [] ["make"] (NoArg (phase Link)) "Build .pgf file and other output files.",
+     Option [] ["cpu"] (NoArg (cpu True)) "Show compilation CPU time statistics.",
+     Option [] ["no-cpu"] (NoArg (cpu False)) "Don't show compilation CPU time statistics (default).",
+     Option [] ["emit-gfo"] (NoArg (emitGFO True)) "Create .gfo files (default).",
+     Option [] ["no-emit-gfo"] (NoArg (emitGFO False)) "Do not create .gfo files.",
+     Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').",
+     Option ['f'] ["output-format"] (ReqArg outFmt "FMT") 
+        (unlines ["Output format. FMT can be one of:",
+                  "Multiple concrete: pgf (default), gar, js, ...",
+                  "Single concrete only: cf, bnf, lbnf, gsl, srgs_xml, srgs_abnf, ...",
+                  "Abstract only: haskell, ..."]),
+     Option [] ["sisr"] (ReqArg sisrFmt "FMT") 
+        (unlines ["Include SISR tags in generated speech recognition grammars.",
+                  "FMT can be one of: old, 1.0"]),
+     Option ['o'] ["output-file"] (ReqArg outFile "FILE") 
+           "Save output in FILE (default is out.X, where X depends on output format.",
+     Option ['D'] ["output-dir"] (ReqArg outDir "DIR") 
+           "Save output files (other than .gfc files) in DIR.",
+     Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp)) 
+                 "Always recompile from source.",
+     Option [] ["gfo","recomp-if-newer"] (NoArg (recomp RecompIfNewer)) 
+                 "(default) Recompile from source if the source is newer than the .gfo file.",
+     Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp)) 
+                 "Never recompile from source, if there is already .gfo file.",
+     Option [] ["strip"] (NoArg (printer PrinterStrip))
+                 "Remove name qualifiers when pretty-printing.",
+     Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.",
+     Option [] ["prob"] (NoArg (prob True)) "Read probabilities from '--# prob' pragmas."
+    ] ++ map (fmap (liftM moduleOptions)) moduleOptDescr
+ where phase       x = set $ \o -> o { optStopAfterPhase = x }
+       mode        x = set $ \o -> o { optMode = x }
+       verbosity mv  = case mv of
+                           Nothing -> set $ \o -> o { optVerbosity = Verbose }
+                           Just v  -> case readMaybe v >>= toEnumBounded of
+                                        Just i  -> set $ \o -> o { optVerbosity = i }
+                                        Nothing -> fail $ "Bad verbosity: " ++ show v
+       cpu         x = set $ \o -> o { optShowCPUTime = x }
+       emitGFO     x = set $ \o -> o { optEmitGFO = x }
+       gfoDir      x = set $ \o -> o { optGFODir = x }
+       outFmt      x = readOutputFormat x >>= \f ->
+                         set $ \o -> o { optOutputFormats = optOutputFormats o ++ [f] }
+       sisrFmt     x = case x of
+                         "old" -> set $ \o -> o { optSISR = Just SISR_WD20030401 }
+                         "1.0" -> set $ \o -> o { optSISR = Just SISR_1_0 }
+                         _     -> fail $ "Unknown SISR format: " ++ show x
+       outFile     x = set $ \o -> o { optOutputFile = Just x }
+       outDir      x = set $ \o -> o { optOutputDir = Just x }
+       recomp      x = set $ \o -> o { optRecomp = x }
+       printer     x = set $ \o -> o { optPrinter = x : optPrinter o }
+       prob        x = set $ \o -> o { optProb = x }
+
+       set = return . Options
+
+outputFormats :: [(String,OutputFormat)]
+outputFormats = 
+    [("pgf",          FmtPGF),
+     ("js",           FmtJavaScript),
+     ("haskell",      FmtHaskell),
+     ("haskell_gadt", FmtHaskell_GADT),
+     ("bnf",          FmtBNF),
+     ("srgs_xml",     FmtSRGS_XML),
+     ("srgs_abnf",    FmtSRGS_ABNF),
+     ("jsgf",         FmtJSGF),
+     ("gsl",          FmtGSL),
+     ("vxml",         FmtVoiceXML),
+     ("slf",          FmtSLF),
+     ("regexp",       FmtRegExp),
+     ("fa",           FmtFA)]
+
+instance Show OutputFormat where
+    show = lookupShow outputFormats
+
+instance Read OutputFormat where
+    readsPrec = lookupReadsPrec outputFormats
+
+optimizationPackages :: [(String, Set Optimization)]
+optimizationPackages = 
+    [("all_subs",    Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize,OptValues]), -- deprecated
+     ("all",         Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize,OptValues]),
+     ("values",      Set.fromList [OptStem,OptCSE,OptExpand,OptValues]),
+     ("parametrize", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
+     ("none",        Set.fromList [OptStem,OptCSE,OptExpand]),
+     ("noexpand",    Set.fromList [OptStem,OptCSE])]
+
+encodings :: [(String,Encoding)]
+encodings = 
+    [("utf8",   UTF_8),
+     ("cp1251", CP_1251),
+     ("latin1", ISO_8859_1)
+    ]
+
+lookupShow :: Eq a => [(String,a)] -> a -> String
+lookupShow xs z = fromMaybe "lookupShow" $ lookup z [(y,x) | (x,y) <- xs]
+
+lookupReadsPrec :: [(String,a)] -> Int -> ReadS a
+lookupReadsPrec xs _ s = [(z,rest) | (x,rest) <- lex s, (y,z) <- xs, y == x]
+
+onOff :: Monad m => (Bool -> m a) -> Bool -> ArgDescr (m a)
+onOff f def = OptArg g "[on,off]"
+  where g ma = maybe (return def) readOnOff ma >>= f
+        readOnOff x = case map toLower x of
+                        "on"  -> return True
+                        "off" -> return False
+                        _     -> fail $ "Expected [on,off], got: " ++ show x
+
+readOutputFormat :: Monad m => String -> m OutputFormat
+readOutputFormat s = 
+    maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats
+
+-- FIXME: this is a copy of the function in GF.Devel.UseIO.
+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 == ';'
+
+-- 
+-- * Convenience functions for checking options
+--
+
+verbAtLeast :: Options -> Verbosity -> Bool
+verbAtLeast opts v = flag optVerbosity opts >= v
+
+dump :: Options -> Dump -> Bool
+dump opts d = moduleFlag ((d `elem`) . optDump) opts
+
+-- 
+-- * Convenience functions for setting options
+--
+
+setOptimization :: Optimization -> Bool -> Options
+setOptimization o b = modifyModuleFlags (setOptimization' o b)
+
+setOptimization' :: Optimization -> Bool -> ModuleFlags -> ModuleFlags
+setOptimization' o b f = f { optOptimizations = g (optOptimizations f)}
+  where g = if b then Set.insert o else Set.delete o
+
+--
+-- * General utilities
+--
+
+readMaybe :: Read a => String -> Maybe a
+readMaybe s = case reads s of
+                [(x,"")] -> Just x
+                _        -> Nothing
+
+toEnumBounded :: (Bounded a, Enum a, Ord a) => Int -> Maybe a
+toEnumBounded i = let mi = minBound
+                      ma = maxBound `asTypeOf` mi                      
+                   in if i >= fromEnum mi && i <= fromEnum ma 
+                        then Just (toEnum i `asTypeOf` mi)
+                        else Nothing
+
+
+instance Functor OptDescr where
+    fmap f (Option cs ss d s) = Option cs ss (fmap f d) s
+
+instance Functor ArgDescr where
+    fmap f (NoArg x)    = NoArg (f x)
+    fmap f (ReqArg g s) = ReqArg (f . g) s
+    fmap f (OptArg g s) = OptArg (f . g) s
diff --git a/src/GF/Infra/PrintClass.hs b/src/GF/Infra/PrintClass.hs
new file mode 100644
index 000000000..5e94984a6
--- /dev/null
+++ b/src/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/GF/Infra/UseIO.hs b/src/GF/Infra/UseIO.hs
new file mode 100644
index 000000000..00b956708
--- /dev/null
+++ b/src/GF/Infra/UseIO.hs
@@ -0,0 +1,277 @@
+{-# 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.Infra.Option
+import Paths_gf(getDataDir)
+
+import System.Directory
+import System.FilePath
+import System.IO
+import System.IO.Error
+import System.Environment
+import System.Exit
+import System.CPUTime
+import Control.Monad
+import Control.Exception(evaluate)
+import qualified Data.ByteString.Char8 as BS
+
+putShow' :: Show a => (c -> a) -> c -> IO ()
+putShow' f = putStrLn . show . length . show . f
+
+putIfVerb :: Options -> String -> IO ()
+putIfVerb opts msg =
+      when (verbAtLeast opts Verbose) $ putStrLn msg
+
+putIfVerbW :: Options -> String -> IO ()
+putIfVerbW opts msg =
+      when (verbAtLeast opts Verbose) $ putStr (' ' : msg)
+
+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
+
+readFileIf f = catch (readFile f) (\_ -> reportOn f) where
+ reportOn f = do
+   putStrLnFlush ("File " ++ f ++ " does not exist. Returned empty string")
+   return ""
+
+readFileIfStrict f = catch (BS.readFile f) (\_ -> reportOn f) where
+ reportOn f = do
+   putStrLnFlush ("File " ++ f ++ " does not exist. Returned empty string")
+   return BS.empty
+
+type FileName = String
+type InitPath = String
+type FullPath = String
+
+getFilePath :: [FilePath] -> String -> IO (Maybe FilePath)
+getFilePath ps file = getFilePathMsg ("file" +++ file +++ "not found\n") ps file
+
+getFilePathMsg :: String -> [FilePath] -> String -> IO (Maybe FilePath)
+getFilePathMsg msg paths file = get paths where
+  get []     = putStrFlush msg >> return Nothing
+  get (p:ps) = do
+    let pfile = p </> file
+    exist <- doesFileExist pfile
+    if not exist
+      then get ps
+      else do pfile <- canonicalizePath pfile
+              return (Just pfile)
+
+readFileIfPath :: [FilePath] -> String -> IOE (FilePath,BS.ByteString)
+readFileIfPath paths file = do
+  mpfile <- ioeIO $ getFilePath paths file
+  case mpfile of
+    Just pfile -> do
+      s <- ioeIO $ BS.readFile 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"
+gfGrammarPathVar = "GF_GRAMMAR_PATH"
+
+getLibraryPath :: IO FilePath
+getLibraryPath =
+  catch
+    (getEnv gfLibraryPath)
+    (\ex -> getDataDir >>= \path -> return (path </> "lib"))
+
+-- | 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)
+
+dieIOE :: IOE a -> IO a
+dieIOE x = appIOE x >>= err die return
+
+die :: String -> IO a
+die s = do hPutStrLn stderr s
+           exitFailure
+
+putStrLnE :: String -> IOE ()
+putStrLnE = ioeIO . putStrLnFlush 
+
+putStrE :: String -> IOE ()
+putStrE = ioeIO . putStrFlush 
+
+putPointE :: Verbosity -> Options -> String -> IOE a -> IOE a
+putPointE v opts msg act = do
+  when (verbAtLeast opts v) $ ioeIO $ putStrFlush msg
+
+  t1 <- ioeIO $ getCPUTime
+  a <- act >>= ioeIO . evaluate
+  t2 <- ioeIO $ getCPUTime
+
+  if flag optShowCPUTime opts
+      then putStrLnE (" " ++ show ((t2 - t1) `div` 1000000000) ++ " msec")
+      else when (verbAtLeast opts v) $ putStrLnE ""
+
+  return a
+
+
+-- ((do {s <- readFile f; return (return s)}) ) 
+readFileIOE :: FilePath -> IOE BS.ByteString
+readFileIOE f = ioe $ catch (BS.readFile 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, BS.ByteString)
+readFileLibraryIOE ini f = ioe $ do
+  lp <- getLibraryPath
+  tryRead ini $ \_ ->
+    tryRead lp  $ \e ->
+      return (Bad (show e))
+  where
+    tryRead path onError =
+      catch (BS.readFile 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
+