summaryrefslogtreecommitdiff
path: root/src/GF
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF')
-rw-r--r--src/GF/Devel/Arch.hs89
-rw-r--r--src/GF/Devel/Compile.hs218
-rw-r--r--src/GF/Devel/GFC.hs20
-rw-r--r--src/GF/Devel/GetGrammar.hs54
-rw-r--r--src/GF/Devel/GrammarToGFCC.hs471
-rw-r--r--src/GF/Devel/PrGrammar.hs233
-rw-r--r--src/GF/Devel/ReadFiles.hs356
-rw-r--r--src/GF/Devel/UseIO.hs344
8 files changed, 1785 insertions, 0 deletions
diff --git a/src/GF/Devel/Arch.hs b/src/GF/Devel/Arch.hs
new file mode 100644
index 000000000..dedb1b4f5
--- /dev/null
+++ b/src/GF/Devel/Arch.hs
@@ -0,0 +1,89 @@
+----------------------------------------------------------------------
+-- |
+-- Module : Arch
+-- Maintainer : AR
+-- Stability : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/10 14:55:01 $
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.8 $
+--
+-- architecture\/compiler dependent definitions for unix\/hbc
+-----------------------------------------------------------------------------
+
+module GF.Devel.Arch (
+ myStdGen, prCPU, selectLater, modifiedFiles, ModTime, getModTime,getNowTime,
+ welcomeArch, laterModTime) where
+
+import System.Time
+import System.Random
+import System.CPUTime
+import Control.Monad (filterM)
+import System.Directory
+
+
+---- import qualified UnicodeF as U --(fudlogueWrite)
+
+-- architecture/compiler dependent definitions for unix/hbc
+
+myStdGen :: Int -> IO StdGen ---
+--- myStdGen _ = newStdGen --- gives always the same result
+myStdGen int0 = do
+ t0 <- getClockTime
+ cal <- toCalendarTime t0
+ let int = int0 + ctSec cal + fromInteger (div (ctPicosec cal) 10000000)
+ return $ mkStdGen int
+
+prCPU :: Integer -> IO Integer
+prCPU cpu = do
+ cpu' <- getCPUTime
+ putStrLn (show ((cpu' - cpu) `div` 1000000000) ++ " msec")
+ return cpu'
+
+welcomeArch :: String
+welcomeArch = "This is the system compiled with ghc."
+
+-- | selects the one with the later modification time of two
+selectLater :: FilePath -> FilePath -> IO FilePath
+selectLater x y = do
+ ex <- doesFileExist x
+ if not ex
+ then return y --- which may not exist
+ else do
+ ey <- doesFileExist y
+ if not ey
+ then return x
+ else do
+ tx <- getModificationTime x
+ ty <- getModificationTime y
+ return $ if tx < ty then y else x
+
+-- | a file is considered modified also if it has not been read yet
+--
+-- new 23\/2\/2004: the environment ofs has just module names
+modifiedFiles :: [(FilePath,ModTime)] -> [FilePath] -> IO [FilePath]
+modifiedFiles ofs fs = do
+ filterM isModified fs
+ where
+ isModified file = case lookup (justModName file) ofs of
+ Just to -> do
+ t <- getModificationTime file
+ return $ to < t
+ _ -> return True
+
+ justModName =
+ reverse . takeWhile (/='/') . tail . dropWhile (/='.') . reverse
+
+type ModTime = ClockTime
+
+laterModTime :: ModTime -> ModTime -> Bool
+laterModTime = (>)
+
+getModTime :: FilePath -> IO (Maybe ModTime)
+getModTime f = do
+ b <- doesFileExist f
+ if b then (getModificationTime f >>= return . Just) else return Nothing
+
+getNowTime :: IO ModTime
+getNowTime = getClockTime
diff --git a/src/GF/Devel/Compile.hs b/src/GF/Devel/Compile.hs
new file mode 100644
index 000000000..0649760fe
--- /dev/null
+++ b/src/GF/Devel/Compile.hs
@@ -0,0 +1,218 @@
+module GF.Devel.Compile (batchCompile) where
+
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Infra.Option
+import GF.Infra.CompactPrint
+import GF.Devel.PrGrammar
+import GF.Compile.Update
+import GF.Grammar.Lookup
+import GF.Infra.Modules
+import GF.Devel.ReadFiles
+--import GF.Compile.ShellState
+--import GF.Compile.MkResource
+
+-- the main compiler passes
+import GF.Devel.GetGrammar
+import GF.Compile.Extend
+import GF.Compile.Rebuild
+import GF.Compile.Rename
+import GF.Grammar.Refresh
+import GF.Compile.CheckGrammar
+import GF.Compile.Optimize
+import GF.Compile.Evaluate ----
+--import GF.Compile.GrammarToCanon
+--import GF.Compile.GrammarToGFCC -----
+--import GF.Canon.Share
+--import GF.Canon.Subexpressions (elimSubtermsMod,unSubelimModule)
+--import GF.UseGrammar.Linear (unoptimizeCanonMod) ----
+
+--import qualified GF.Canon.CanonToGrammar as CG
+
+--import qualified GF.Canon.GFC as GFC
+--import qualified GF.Canon.MkGFC as MkGFC
+--import GF.Canon.GetGFC
+
+import GF.Data.Operations
+import GF.Devel.UseIO
+import GF.Devel.Arch
+
+import Control.Monad
+import System.Directory
+
+batchCompile :: [FilePath] -> IO SourceGrammar
+batchCompile files = do
+ let defOpts = options [emitCode]
+ Ok (_,gr) <- appIOE $ foldM (compileModule defOpts) emptyCompileEnv files
+ return gr
+
+-- | environment variable for grammar search path
+gfGrammarPathVar = "GF_GRAMMAR_PATH"
+
+-- | the environment
+type CompileEnv = (Int,SourceGrammar)
+
+-- | compile with one module as starting point
+-- command-line options override options (marked by --#) in the file
+-- As for path: if it is read from file, the file path is prepended to each name.
+-- If from command line, it is used as it is.
+compileModule :: Options -> CompileEnv -> FilePath -> IOE CompileEnv
+compileModule opts1 env file = do
+ opts0 <- ioeIO $ getOptionsFromFile file
+ let useFileOpt = maybe False (const True) $ getOptVal opts0 pathList
+ let useLineOpt = maybe False (const True) $ getOptVal opts1 pathList
+ let opts = addOptions opts1 opts0
+ let fpath = justInitPath file
+ ps0 <- ioeIO $ pathListOpts opts fpath
+
+ let ps1 = if (useFileOpt && not useLineOpt)
+ then (ps0 ++ map (prefixPathName fpath) ps0)
+ else ps0
+ ps <- ioeIO $ extendPathEnv gfLibraryPath gfGrammarPathVar ps1
+ let ioeIOIf = if oElem beVerbose opts then ioeIO else (const (return ()))
+ ioeIOIf $ putStrLn $ "module search path:" +++ show ps ----
+ let st = env
+ let rfs = [] ---- files already in memory and their read times
+ let file' = if useFileOpt then justFileName file else file -- to find file itself
+ files <- getAllFiles opts ps rfs file'
+ ioeIOIf $ putStrLn $ "files to read:" +++ show files ----
+ let names = map justModuleName files
+ ioeIOIf $ putStrLn $ "modules to include:" +++ show names ----
+ let env0 = compileEnvShSt st names
+ (e,mm) <- foldIOE (compileOne opts) env0 files
+ maybe (return ()) putStrLnE mm
+ return e
+
+compileEnvShSt :: CompileEnv -> [ModName] -> CompileEnv
+compileEnvShSt env@(_,sgr) fs = (0,sgr) where
+ sgr = MGrammar [m | m@(i,_) <- modules sgr, notElem (prt i) $ map fileBody fs]
+
+compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
+compileOne opts env@(_,srcgr) file = do
+
+ let putp s = putPointE opts (s ++ "\n")
+ let putpp = putPointEsil opts
+ let putpOpt v m act
+ | oElem beVerbose opts = putp v act
+ | oElem beSilent opts = putpp v act
+ | otherwise = ioeIO (putStrFlush m) >> act
+
+ let gf = fileSuffix file
+ let path = justInitPath file
+ let name = fileBody file
+ let mos = modules srcgr
+
+ case gf of
+
+ -- for compiled gf, read the file and update environment, also source env
+ "gfc" -> do
+ sm0 <- putp ("+ reading" +++ file) $ getSourceModule opts file
+ sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule mos sm0
+ extendCompileEnv env sm
+
+ -- for gf source, do full compilation
+ _ -> do
+
+ let modu = unsuffixFile file
+ b1 <- ioeIO $ doesFileExist file
+ if not b1
+ then compileOne opts env $ gfcFile $ modu
+ else do
+
+ sm0 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $
+ getSourceModule opts file
+ (k',sm) <- compileSourceModule opts env sm0
+ cm <- putpp " generating code... " $ generateModuleCode opts path sm
+
+ extendCompileEnvInt env (k',sm)
+
+
+compileSourceModule :: Options -> CompileEnv ->
+ SourceModule -> IOE (Int,SourceModule)
+compileSourceModule opts env@(k,gr) mo@(i,mi) = do
+
+ let putp = putPointE opts
+ putpp = putPointEsil opts
+ mos = modules gr
+
+ mo1 <- ioeErr $ rebuildModule mos mo
+
+ mo1b <- ioeErr $ extendModule mos mo1
+
+ case mo1b of
+ (_,ModMod n) | not (isCompleteModule n) -> do
+ return (k,mo1b) -- refresh would fail, since not renamed
+ _ -> do
+ mo2:_ <- putpp " renaming " $ ioeErr $ renameModule mos mo1b
+
+ (mo3:_,warnings) <- putpp " type checking" $ ioeErr $ showCheckModule mos mo2
+ if null warnings then return () else putp warnings $ return ()
+
+ (k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3
+
+ let eenv = emptyEEnv
+ (mo4,eenv') <-
+ ---- if oElem "check_only" opts
+ putpp " optimizing " $ ioeErr $ optimizeModule opts (mos,eenv) mo3r
+ return (k',mo4)
+ where
+ ---- prDebug mo = ioeIO $ putStrLn $ prGrammar $ MGrammar [mo] ---- debug
+ prDebug mo = ioeIO $ print $ length $ lines $ prGrammar $ MGrammar [mo]
+
+generateModuleCode :: Options -> InitPath -> SourceModule -> IOE SourceModule
+generateModuleCode opts path minfo@(name,info) = do
+
+ let pname = prefixPathName path (prt name)
+ let minfo0 = minfo
+ let minfo1 = minfo
+ let minfo2 = minfo
+
+{- ---- restore optimizations!
+ let oopts = addOptions opts (iOpts (flagsModule minfo))
+ optims = maybe "all_subs" id $ getOptVal oopts useOptimizer
+ optim = takeWhile (/='_') optims
+ subs = drop 1 (dropWhile (/='_') optims) == "subs"
+ minfo1 <- return $
+ case optim of
+ "parametrize" -> shareModule paramOpt minfo0 -- parametrization and sharing
+ "values" -> shareModule valOpt minfo0 -- tables as courses-of-values
+ "share" -> shareModule shareOpt minfo0 -- sharing of branches
+ "all" -> shareModule allOpt minfo0 -- first parametrize then values
+ "none" -> minfo0 -- no optimization
+ _ -> shareModule shareOpt minfo0 -- sharing; default
+
+ -- do common subexpression elimination if required by flag "subs"
+ minfo2 <-
+ if subs
+ then ioeErr $ elimSubtermsMod minfo1
+ else return minfo1
+-}
+
+ let (file,out) = (gfcFile pname, prGrammar (MGrammar [minfo2]))
+ putp (" wrote file" +++ file) $ ioeIO $ writeFile file $ compactPrint out
+
+ return minfo2
+ where
+ putp = putPointE opts
+ putpp = putPointEsil opts
+ isCompilable mi = case mi of
+ ModMod m -> not $ isModCnc m && mstatus m == MSIncomplete
+ _ -> True
+
+
+-- auxiliaries
+
+pathListOpts :: Options -> FileName -> IO [InitPath]
+pathListOpts opts file = return $ maybe [file] pFilePaths $ getOptVal opts pathList
+
+reverseModules (MGrammar ms) = MGrammar $ reverse ms
+
+emptyCompileEnv :: CompileEnv
+emptyCompileEnv = (0,emptyMGrammar)
+
+extendCompileEnvInt (_,MGrammar ss) (k,sm) =
+ return (k,MGrammar (sm:ss)) --- reverse later
+
+extendCompileEnv e@(k,_) sm = extendCompileEnvInt e (k,sm)
+
+
diff --git a/src/GF/Devel/GFC.hs b/src/GF/Devel/GFC.hs
new file mode 100644
index 000000000..561d37060
--- /dev/null
+++ b/src/GF/Devel/GFC.hs
@@ -0,0 +1,20 @@
+module Main where
+
+import GF.Devel.Compile
+import GF.Devel.GrammarToGFCC
+
+import System
+
+
+main = do
+ xx <- getArgs
+ case xx of
+ "-help":[] -> putStrLn "usage: gfc (--make) FILES"
+ "--make":fs -> do
+ gr <- batchCompile fs
+ putStrLn $ prGrammar2gfcc gr ---
+--- writeFile "a.gfcc" $ prGrammar2gfcc gr
+--- putStrLn "wrote file a.gfcc"
+ _ -> do
+ mapM_ batchCompile (map return xx)
+ putStrLn "Done."
diff --git a/src/GF/Devel/GetGrammar.hs b/src/GF/Devel/GetGrammar.hs
new file mode 100644
index 000000000..49546b6ea
--- /dev/null
+++ b/src/GF/Devel/GetGrammar.hs
@@ -0,0 +1,54 @@
+----------------------------------------------------------------------
+-- |
+-- Module : GetGrammar
+-- Maintainer : AR
+-- Stability : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/15 17:56:13 $
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.16 $
+--
+-- this module builds the internal GF grammar that is sent to the type checker
+-----------------------------------------------------------------------------
+
+module GF.Devel.GetGrammar where
+
+import GF.Data.Operations
+import qualified GF.Data.ErrM as E ----
+
+import GF.Devel.UseIO
+import GF.Grammar.Grammar
+import GF.Infra.Modules
+import GF.Devel.PrGrammar
+import qualified GF.Source.AbsGF as A
+import GF.Source.SourceToGrammar
+---- import Macros
+---- import Rename
+import GF.Infra.Option
+--- import Custom
+import GF.Source.ParGF
+import qualified GF.Source.LexGF as L
+
+import GF.Devel.ReadFiles ----
+
+import Data.Char (toUpper)
+import Data.List (nub)
+import Control.Monad (foldM)
+import System (system)
+
+getSourceModule :: Options -> FilePath -> IOE SourceModule
+getSourceModule opts file0 = do
+ file <- case getOptVal opts usePreprocessor of
+ Just p -> do
+ let tmp = "_gf_preproc.tmp"
+ cmd = p +++ file0 ++ ">" ++ tmp
+ ioeIO $ system cmd
+ -- ioeIO $ putStrLn $ "preproc" +++ cmd
+ return tmp
+ _ -> return file0
+ string <- readFileIOE file
+ let tokens = myLexer string
+ mo1 <- ioeErr $ {- err2err $ -} pModDef tokens
+ ioeErr $ transModDef mo1
+
diff --git a/src/GF/Devel/GrammarToGFCC.hs b/src/GF/Devel/GrammarToGFCC.hs
new file mode 100644
index 000000000..a6dabae1a
--- /dev/null
+++ b/src/GF/Devel/GrammarToGFCC.hs
@@ -0,0 +1,471 @@
+module GF.Devel.GrammarToGFCC (prGrammar2gfcc) where
+
+import GF.Grammar.Grammar
+import qualified GF.Grammar.Lookup as Look
+
+import qualified GF.Canon.GFCC.AbsGFCC as C
+import qualified GF.Canon.GFCC.PrintGFCC as Pr
+import qualified GF.Grammar.Abstract as A
+import qualified GF.Grammar.Macros as GM
+import qualified GF.Infra.Modules as M
+import qualified GF.Infra.Option as O
+
+import GF.Infra.Ident
+import GF.Data.Operations
+import GF.Text.UTF8
+
+import Data.List
+import qualified Data.Map as Map
+import Debug.Trace ----
+
+-- the main function: generate GFCC from GF.
+
+prGrammar2gfcc :: SourceGrammar-> String
+prGrammar2gfcc = Pr.printTree . mkCanon2gfcc
+
+mkCanon2gfcc :: SourceGrammar -> C.Grammar
+mkCanon2gfcc = canon2gfcc . reorder . utf8Conv . canon2canon
+
+-- This is needed to reorganize the grammar. GFCC has its own back-end optimization.
+-- But we need to have the canonical order in tables, created by valOpt
+
+-- Generate GFCC from GFCM.
+-- this assumes a grammar translated by canon2canon
+
+canon2gfcc :: SourceGrammar -> C.Grammar
+canon2gfcc cgr@(M.MGrammar ((a,M.ModMod abm):cms)) =
+ C.Grm (C.Hdr (i2i a) cs) (C.Abs adefs) cncs where
+ cs = map (i2i . fst) cms
+ adefs = [C.Fun f' (mkType ty) (C.Tr (C.AC f') []) |
+ (f,AbsFun (Yes ty) _) <- tree2list (M.jments abm), let f' = i2i f]
+ cncs = [C.Cnc (i2i a) (concr abm)]
+ concr mo = cats mo ++ lindefs mo ++
+ optConcrete
+ [C.Lin (i2i f) (mkTerm tr) |
+ (f,CncFun _ (Yes tr) _) <- tree2list (M.jments mo)]
+ cats mo = [C.Lin (i2ic c) (mkCType ty) |
+ (c,CncCat (Yes ty) _ _) <- tree2list (M.jments mo)]
+ lindefs mo = [C.Lin (i2id c) (mkTerm tr) |
+ (c,CncCat _ (Yes tr) _) <- tree2list (M.jments mo)]
+
+i2i :: Ident -> C.CId
+i2i (IC c) = C.CId c
+i2ic (IC c) = C.CId ("__" ++ c) -- for lincat of category symbols
+i2id (IC c) = C.CId ("_d" ++ c) -- for lindef of category symbols
+
+mkType :: A.Type -> C.Type
+mkType t = case GM.catSkeleton t of
+ Ok (cs,c) -> C.Typ (map (i2i . snd) cs) (i2i $ snd c)
+
+mkCType :: Type -> C.Term
+mkCType t = case t of
+ EInt i -> C.C $ fromInteger i
+ -- record parameter alias - created in gfc preprocessing
+ RecType [(LIdent "_", i), (LIdent "__", t)] -> C.RP (mkCType i) (mkCType t)
+ RecType rs -> C.R [mkCType t | (_, t) <- rs]
+ Table pt vt -> C.R $ replicate (getI (mkCType pt)) $ mkCType vt
+ _ -> C.S [] ----- TStr
+ where
+ getI pt = case pt of
+ C.C i -> i
+ C.RP i _ -> getI i
+ _ -> 1 -----
+
+mkTerm :: Term -> C.Term
+mkTerm tr = case tr of
+ Vr (IA (_,i)) -> C.V i
+ EInt i -> C.C $ fromInteger i
+ -- record parameter alias - created in gfc preprocessing
+ R [(LIdent "_", (_,i)), (LIdent "__", (_,t))] -> C.RP (mkTerm i) (mkTerm t)
+ -- ordinary record
+ R rs -> C.R [mkTerm t | (_, (_,t)) <- rs]
+ P t l -> C.P (mkTerm t) (C.C (mkLab l))
+
+----- LI x -> C.BV $ i2i x
+----- T _ [(PV x, t)] -> C.L (i2i x) (mkTerm t)
+
+ T _ cs -> C.R [mkTerm t | (_,t) <- cs] ------
+ V _ cs -> C.R [mkTerm t | t <- cs]
+ S t p -> C.P (mkTerm t) (mkTerm p)
+ C s t -> C.S [mkTerm x | x <- [s,t]]
+ FV ts -> C.FV [mkTerm t | t <- ts]
+ K s -> C.K (C.KS s)
+----- K (KP ss _) -> C.K (C.KP ss []) ---- TODO: prefix variants
+ Empty -> C.S []
+ App _ _ -> prtTrace tr $ C.C 66661 ---- for debugging
+ Abs _ t -> mkTerm t ---- only on toplevel
+ _ -> C.S [C.K (C.KS (A.prt tr +++ "66662"))] ---- for debugging
+ where
+ mkLab (LIdent l) = case l of
+ '_':ds -> (read ds) :: Int
+ _ -> prtTrace tr $ 66663
+
+-- return just one module per language
+
+reorder :: SourceGrammar -> SourceGrammar
+reorder cg = M.MGrammar $
+ (abs, M.ModMod $
+ M.Module M.MTAbstract M.MSComplete [] [] [] adefs):
+ [(c, M.ModMod $
+ M.Module (M.MTConcrete abs) M.MSComplete [] [] [] (sorted2tree js))
+ | (c,js) <- cncs]
+ where
+ abs = maybe (error "no abstract") id $ M.greatestAbstract cg
+ mos = M.allModMod cg
+ adefs =
+ sorted2tree $ sortBy (\ (f,_) (g,_) -> compare f g)
+ [finfo |
+ (i,mo) <- M.allModMod cg, M.isModAbs mo,
+ finfo <- tree2list (M.jments mo)]
+ cncs = sortBy (\ (x,_) (y,_) -> compare x y)
+ [(lang, concr lang) | lang <- M.allConcretes cg abs]
+ concr la = sortBy (\ (f,_) (g,_) -> compare f g)
+ [finfo |
+ (i,mo) <- mos, M.isModCnc mo, elem i (M.allExtends cg la),
+ finfo <- tree2list (M.jments mo)]
+
+-- one grammar per language - needed for symtab generation
+repartition :: SourceGrammar -> [SourceGrammar]
+repartition cg = [M.partOfGrammar cg (lang,mo) |
+ let abs = maybe (error "no abstract") id $ M.greatestAbstract cg,
+ let mos = M.allModMod cg,
+ lang <- M.allConcretes cg abs,
+ let mo = errVal
+ (error ("no module found for " ++ A.prt lang)) $ M.lookupModule cg lang
+ ]
+
+-- convert to UTF8 if not yet converted
+utf8Conv :: SourceGrammar -> SourceGrammar
+utf8Conv = M.MGrammar . map toUTF8 . M.modules where
+ toUTF8 mo = case mo of
+ (i, M.ModMod m)
+ ----- | hasFlagCanon (flagCanon "coding" "utf8") mo -> mo
+ | otherwise -> (i, M.ModMod $
+ m{ M.jments = M.jments m -----
+----- mapTree (onSnd (mapInfoTerms (onTokens encodeUTF8))) (M.jments m),
+ ----- M.flags = setFlag "coding" "utf8" (M.flags m)
+ }
+ )
+ _ -> mo
+
+
+-- translate tables and records to arrays, parameters and labels to indices
+
+canon2canon :: SourceGrammar -> SourceGrammar
+canon2canon = recollect . map cl2cl . repartition where
+ recollect =
+ M.MGrammar . nubBy (\ (i,_) (j,_) -> i==j) . concatMap M.modules
+ cl2cl cg = tr $ M.MGrammar $ map c2c $ M.modules cg where
+ c2c (c,m) = case m of
+ M.ModMod mo@(M.Module _ _ _ _ _ js) ->
+ (c, M.ModMod $ M.replaceJudgements mo $ mapTree j2j js)
+ _ -> (c,m)
+ j2j (f,j) = case j of
+ CncFun x (Yes tr) z -> (f,CncFun x (Yes (t2t tr)) z)
+ CncCat (Yes ty) (Yes x) y -> (f,CncCat (Yes (ty2ty ty)) (Yes (t2t x)) y)
+ _ -> (f,j)
+ t2t = term2term cg pv
+ ty2ty = type2type cg pv
+ pv@(labels,untyps,typs) = paramValues cg
+ tr = trace $
+ (unlines [A.prt c ++ "." ++ unwords (map A.prt l) +++ "=" +++ show i |
+ ((c,l),i) <- Map.toList labels]) ++
+ (unlines [A.prt t +++ "=" +++ show i |
+ (t,i) <- Map.toList untyps]) ++
+ (unlines [A.prt t |
+ (t,_) <- Map.toList typs])
+
+type ParamEnv =
+ (Map.Map (Ident,[Label]) (Type,Integer), -- numbered labels
+ Map.Map Term Integer, -- untyped terms to values
+ Map.Map Type (Map.Map Term Integer)) -- types to their terms to values
+
+--- gathers those param types that are actually used in lincats and in lin terms
+paramValues :: SourceGrammar -> ParamEnv
+paramValues cgr = (labels,untyps,typs) where
+ params = [(ty, errVal [] $ Look.allParamValues cgr ty) | ty <- partyps]
+ partyps = nub $ [ty |
+ (_,(_,CncCat (Yes (RecType ls)) _ _)) <- jments,
+ ty0 <- [ty | (_, ty) <- unlockTyp ls],
+ ty <- typsFrom ty0
+ ] ++ [
+ Q m ty |
+ (m,(ty,ResParam _)) <- jments
+ ] ++ [ty |
+ (_,(_,CncFun _ (Yes tr) _)) <- jments,
+ ty <- err (const []) snd $ appSTM (typsFromTrm tr) []
+ ]
+ typsFrom ty = case ty of
+ Table p t -> typsFrom p ++ typsFrom t
+ RecType ls -> RecType (unlockTyp ls) : concat [typsFrom t | (_, t) <- ls]
+ _ -> [ty]
+
+ typsFromTrm :: Term -> STM [Type] Term
+ typsFromTrm tr = case tr of
+ V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr
+ T (TTyped ty) cs -> updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr
+ _ -> GM.composOp typsFromTrm tr
+
+
+ jments = [(m,j) | (m,mo) <- M.allModMod cgr, j <- tree2list $ M.jments mo]
+ typs = Map.fromList [(ci,Map.fromList (zip vs [0..])) | (ci,vs) <- params]
+ untyps = Map.fromList $ concatMap Map.toList [typ | (_,typ) <- Map.toList typs]
+ lincats =
+ [(IC cat,[(LIdent "s",GM.typeStr)]) | cat <- ["Int", "Float", "String"]] ++
+ [(cat,(unlockTyp ls)) | (_,(cat,CncCat (Yes (RecType ls)) _ _)) <- jments]
+ labels = Map.fromList $ concat
+ [((cat,[lab]),(typ,i)):
+ [((cat,[lab,lab2]),(ty,j)) |
+ rs <- getRec typ, ((lab2, ty),j) <- zip rs [0..]]
+ |
+ (cat,ls) <- lincats, ((lab, typ),i) <- zip ls [0..]]
+ -- go to tables recursively
+ ---- TODO: even go to deeper records
+ where
+ getRec typ = case typ of
+ RecType rs -> [rs]
+ Table _ t -> getRec t
+ _ -> []
+
+type2type :: SourceGrammar -> ParamEnv -> Type -> Type
+type2type cgr env@(labels,untyps,typs) ty = case ty of
+ RecType rs ->
+ let
+ rs' = [(mkLab i, t2t t) |
+ (i,(l, t)) <- zip [0..] (unlockTyp rs)]
+ in if (any isStrType [t | (_, t) <- rs])
+ then RecType rs'
+ else RecType [(LIdent "_", look ty), (LIdent "__", RecType rs')]
+
+ Table pt vt -> Table (t2t pt) (t2t vt)
+ Cn _ -> look ty
+ _ -> ty
+ where
+ t2t = type2type cgr env
+ look ty = EInt $ toInteger $ case Map.lookup ty typs of
+ Just vs -> length $ Map.assocs vs
+ _ -> trace ("unknown partype " ++ show ty) 1 ---- 66669
+
+term2term :: SourceGrammar -> ParamEnv -> Term -> Term
+term2term cgr env@(labels,untyps,typs) tr = case tr of
+ App _ _ -> mkValCase tr
+ QC _ _ -> mkValCase tr
+ R rs ->
+ let
+ rs' = [(mkLab i, (Nothing, t2t t)) |
+ (i,(l,(_,t))) <- zip [0..] (unlock rs)]
+ in if (any (isStr . trmAss) rs)
+ then R rs'
+ else R [(LIdent "_", (Nothing, mkValCase tr)), (LIdent "__",(Nothing,R rs'))]
+ P t l -> r2r tr
+ PI t l i -> EInt $ toInteger i
+
+----- T ti [Cas ps@[PV _] t] -> T ti [Cas ps (t2t t)]
+
+ T (TTyped ty) cs -> V ty [t2t t | (_, t) <- cs]
+ ---- _ -> K (KS (A.prt tr +++ prtTrace tr "66668"))
+ V ty ts -> V ty [t2t t | t <- ts]
+ S t p -> S (t2t t) (t2t p)
+ _ -> GM.composSafeOp t2t tr
+ where
+ t2t = term2term cgr env
+
+ r2r tr@(P (S (V ty ts) v) l) = t2t $ S (V ty [comp (P t l) | t <- ts]) v
+
+ r2r tr@(P p _) = case getLab tr of
+ Ok (cat,labs) -> P (t2t p) . mkLab $ maybe (prtTrace tr $ 66664) snd $
+ Map.lookup (cat,labs) labels
+ _ -> K ((A.prt tr +++ prtTrace tr "66665"))
+
+ -- this goes recursively into tables (ignored) and records (accumulated)
+ getLab tr = case tr of
+ Vr (IA (cat, _)) -> return (identC cat,[])
+ P p lab2 -> do
+ (cat,labs) <- getLab p
+ return (cat,labs++[lab2])
+ S p _ -> getLab p
+ _ -> Bad "getLab"
+
+ doVar :: Term -> STM [((Type,[Term]),(Term,Term))] Term
+ doVar tr = case getLab tr of
+ Ok (cat, lab) -> do
+ k <- readSTM >>= return . length
+ let tr' = Vr $ identC $ show k -----
+
+ let tyvs = case Map.lookup (cat,lab) labels of
+ Just (ty,_) -> case Map.lookup ty typs of
+ Just vs -> (ty,[t |
+ (t,_) <- sortBy (\x y -> compare (snd x) (snd y))
+ (Map.assocs vs)])
+ _ -> error $ A.prt ty
+ _ -> error $ A.prt tr
+ updateSTM ((tyvs, (tr', tr)):)
+ return tr'
+ _ -> GM.composOp doVar tr
+
+ mkValCase tr = case appSTM (doVar tr) [] of
+ Ok (tr', st@(_:_)) -> t2t $ comp $ foldr mkCase tr' st
+ _ -> valNum tr
+
+ mkCase ((ty,vs),(x,p)) tr =
+ S (V ty [mkBranch x v tr | v <- vs]) p
+ mkBranch x t tr = case tr of
+ _ | tr == x -> t
+ _ -> GM.composSafeOp (mkBranch x t) tr
+
+ valNum tr = maybe (tryPerm tr) EInt $ Map.lookup tr untyps
+ where
+ tryPerm tr = case tr of
+ R rs -> case Map.lookup (R rs) untyps of
+ Just v -> EInt v
+ _ -> valNumFV $ tryVar tr
+ _ -> valNumFV $ tryVar tr
+ tryVar tr = case tr of
+----- Par c ts -> [Par c ts' | ts' <- combinations (map tryVar ts)]
+ FV ts -> ts
+ _ -> [tr]
+ valNumFV ts = case ts of
+ [tr] -> EInt 66667 ----K (KS (A.prt tr +++ prtTrace tr "66667"))
+ _ -> FV $ map valNum ts
+ isStr tr = case tr of
+ App _ _ -> False
+ EInt _ -> False
+ R rs -> any (isStr . trmAss) rs
+ FV ts -> any isStr ts
+ S t _ -> isStr t
+ Empty -> True
+ T _ cs -> any isStr [v | (_, v) <- cs]
+ V _ ts -> any isStr ts
+ P t r -> case getLab tr of
+ Ok (cat,labs) -> case
+ Map.lookup (cat,labs) labels of
+ Just (ty,_) -> isStrType ty
+ _ -> True ---- TODO?
+ _ -> True
+ _ -> True ----
+ trmAss (_,(_, t)) = t
+
+ --- this is mainly needed for parameter record projections
+ comp t = t ----- $ Look.ccompute cgr [] t
+
+isStrType ty = case ty of
+ Sort "Str" -> True
+ RecType ts -> any isStrType [t | (_, t) <- ts]
+ Table _ t -> isStrType t
+ _ -> False
+
+mkLab k = LIdent (("_" ++ show k))
+
+-- remove lock fields; in fact, any empty records and record types
+unlock = filter notlock where
+ notlock (l,(_, t)) = case t of --- need not look at l
+ R [] -> False
+ _ -> True
+unlockTyp = filter notlock where
+ notlock (l, t) = case t of --- need not look at l
+ RecType [] -> False
+ _ -> True
+
+
+prtTrace tr n = n ----trace ("-- ERROR" +++ A.prt tr +++ show n +++ show tr) n
+prTrace tr n = trace ("-- OBSERVE" +++ A.prt tr +++ show n +++ show tr) n
+
+-- back-end optimization:
+-- suffix analysis followed by common subexpression elimination
+
+optConcrete :: [C.CncDef] -> [C.CncDef]
+optConcrete defs = subex
+ [C.Lin f (optTerm t) | C.Lin f t <- defs]
+
+-- analyse word form lists into prefix + suffixes
+-- suffix sets can later be shared by subex elim
+
+optTerm :: C.Term -> C.Term
+optTerm tr = case tr of
+ C.R ts@(_:_:_) | all isK ts -> mkSuff $ optToks [s | C.K (C.KS s) <- ts]
+ C.R ts -> C.R $ map optTerm ts
+ C.P t v -> C.P (optTerm t) v
+ C.L x t -> C.L x (optTerm t)
+ _ -> tr
+ where
+ optToks ss = prf : suffs where
+ prf = pref (head ss) (tail ss)
+ suffs = map (drop (length prf)) ss
+ pref cand ss = case ss of
+ s1:ss2 -> if isPrefixOf cand s1 then pref cand ss2 else pref (init cand) ss
+ _ -> cand
+ isK t = case t of
+ C.K (C.KS _) -> True
+ _ -> False
+ mkSuff ("":ws) = C.R (map (C.K . C.KS) ws)
+ mkSuff (p:ws) = C.W p (C.R (map (C.K . C.KS) ws))
+
+
+-- common subexpression elimination; see ./Subexpression.hs for the idea
+
+subex :: [C.CncDef] -> [C.CncDef]
+subex js = errVal js $ do
+ (tree,_) <- appSTM (getSubtermsMod js) (Map.empty,0)
+ return $ addSubexpConsts tree js
+
+type TermList = Map.Map C.Term (Int,Int) -- number of occs, id
+type TermM a = STM (TermList,Int) a
+
+addSubexpConsts :: TermList -> [C.CncDef] -> [C.CncDef]
+addSubexpConsts tree lins =
+ let opers = sortBy (\ (C.Lin f _) (C.Lin g _) -> compare f g)
+ [C.Lin (fid id) trm | (trm,(_,id)) <- list]
+ in map mkOne $ opers ++ lins
+ where
+ mkOne (C.Lin f trm) = (C.Lin f (recomp f trm))
+ recomp f t = case Map.lookup t tree of
+ Just (_,id) | fid id /= f -> C.F $ fid id -- not to replace oper itself
+ _ -> case t of
+ C.R ts -> C.R $ map (recomp f) ts
+ C.S ts -> C.S $ map (recomp f) ts
+ C.W s t -> C.W s (recomp f t)
+ C.P t p -> C.P (recomp f t) (recomp f p)
+ C.RP t p -> C.RP (recomp f t) (recomp f p)
+ C.L x t -> C.L x (recomp f t)
+ _ -> t
+ fid n = C.CId $ "_" ++ show n
+ list = Map.toList tree
+
+getSubtermsMod :: [C.CncDef] -> TermM TermList
+getSubtermsMod js = do
+ mapM (getInfo collectSubterms) js
+ (tree0,_) <- readSTM
+ return $ Map.filter (\ (nu,_) -> nu > 1) tree0
+ where
+ getInfo get (C.Lin f trm) = do
+ get trm
+ return ()
+
+collectSubterms :: C.Term -> TermM ()
+collectSubterms t = case t of
+ C.R ts -> do
+ mapM collectSubterms ts
+ add t
+ C.RP u v -> do
+ collectSubterms v
+ add t
+ C.S ts -> do
+ mapM collectSubterms ts
+ add t
+ C.W s u -> do
+ collectSubterms u
+ add t
+ C.P p u -> do
+ collectSubterms p
+ collectSubterms u
+ add t
+ _ -> return ()
+ where
+ add t = do
+ (ts,i) <- readSTM
+ let
+ ((count,id),next) = case Map.lookup t ts of
+ Just (nu,id) -> ((nu+1,id), i)
+ _ -> ((1, i ), i+1)
+ writeSTM (Map.insert t (count,id) ts, next)
+
diff --git a/src/GF/Devel/PrGrammar.hs b/src/GF/Devel/PrGrammar.hs
new file mode 100644
index 000000000..44d1c3200
--- /dev/null
+++ b/src/GF/Devel/PrGrammar.hs
@@ -0,0 +1,233 @@
+----------------------------------------------------------------------
+-- |
+-- Module : PrGrammar
+-- Maintainer : AR
+-- Stability : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/09/04 11:45:38 $
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.16 $
+--
+-- AR 7\/12\/1999 - 1\/4\/2000 - 10\/5\/2003
+--
+-- printing and prettyprinting class
+--
+-- 8\/1\/2004:
+-- Usually followed principle: 'prt_' for displaying in the editor, 'prt'
+-- in writing grammars to a file. For some constructs, e.g. 'prMarkedTree',
+-- only the former is ever needed.
+-----------------------------------------------------------------------------
+
+module GF.Devel.PrGrammar where
+
+import GF.Data.Operations
+import GF.Data.Zipper
+import GF.Grammar.Grammar
+import GF.Infra.Modules
+import qualified GF.Source.PrintGF as P
+import GF.Grammar.Values
+import GF.Source.GrammarToSource
+--- import GFC (CanonGrammar) --- cycle of modules
+
+import GF.Infra.Option
+import GF.Infra.Ident
+import GF.Data.Str
+
+import Data.List (intersperse)
+
+class Print a where
+ prt :: a -> String
+ -- | printing with parentheses, if needed
+ prt2 :: a -> String
+ -- | pretty printing
+ prpr :: a -> [String]
+ -- | printing without ident qualifications
+ prt_ :: a -> String
+ prt2 = prt
+ prt_ = prt
+ prpr = return . prt
+
+-- 8/1/2004
+--- Usually followed principle: prt_ for displaying in the editor, prt
+--- in writing grammars to a file. For some constructs, e.g. prMarkedTree,
+--- only the former is ever needed.
+
+-- | to show terms etc in error messages
+prtBad :: Print a => String -> a -> Err b
+prtBad s a = Bad (s +++ prt a)
+
+prGrammar :: SourceGrammar -> String
+prGrammar = P.printTree . trGrammar
+
+prModule :: (Ident, SourceModInfo) -> String
+prModule = P.printTree . trModule
+
+instance Print Term where
+ prt = P.printTree . trt
+ prt_ = prExp
+
+instance Print Ident where
+ prt = P.printTree . tri
+
+instance Print Patt where
+ prt = P.printTree . trp
+
+instance Print Label where
+ prt = P.printTree . trLabel
+
+instance Print MetaSymb where
+ prt (MetaSymb i) = "?" ++ show i
+
+prParam :: Param -> String
+prParam (c,co) = prt c +++ prContext co
+
+prContext :: Context -> String
+prContext co = unwords $ map prParenth [prt x +++ ":" +++ prt t | (x,t) <- co]
+
+
+-- printing values and trees in editing
+
+instance Print a => Print (Tr a) where
+ prt (Tr (n, trees)) = prt n +++ unwords (map prt2 trees)
+ prt2 t@(Tr (_,args)) = if null args then prt t else prParenth (prt t)
+
+-- | we cannot define the method prt_ in this way
+prt_Tree :: Tree -> String
+prt_Tree = prt_ . tree2exp
+
+instance Print TrNode where
+ prt (N (bi,at,vt,(cs,ms),_)) =
+ prBinds bi ++
+ prt at +++ ":" +++ prt vt
+ +++ prConstraints cs +++ prMetaSubst ms
+ prt_ (N (bi,at,vt,(cs,ms),_)) =
+ prBinds bi ++
+ prt_ at +++ ":" +++ prt_ vt
+ +++ prConstraints cs +++ prMetaSubst ms
+
+prMarkedTree :: Tr (TrNode,Bool) -> [String]
+prMarkedTree = prf 1 where
+ prf ind t@(Tr (node, trees)) =
+ prNode ind node : concatMap (prf (ind + 2)) trees
+ prNode ind node = case node of
+ (n, False) -> indent ind (prt_ n)
+ (n, _) -> '*' : indent (ind - 1) (prt_ n)
+
+prTree :: Tree -> [String]
+prTree = prMarkedTree . mapTr (\n -> (n,False))
+
+-- | a pretty-printer for parsable output
+tree2string :: Tree -> String
+tree2string = unlines . prprTree
+
+prprTree :: Tree -> [String]
+prprTree = prf False where
+ prf par t@(Tr (node, trees)) =
+ parIf par (prn node : concat [prf (ifPar t) t | t <- trees])
+ prn (N (bi,at,_,_,_)) = prb bi ++ prt_ at
+ prb [] = ""
+ prb bi = "\\" ++ concat (intersperse "," (map (prt_ . fst) bi)) ++ " -> "
+ parIf par (s:ss) = map (indent 2) $
+ if par
+ then ('(':s) : ss ++ [")"]
+ else s:ss
+ ifPar (Tr (N ([],_,_,_,_), [])) = False
+ ifPar _ = True
+
+
+-- auxiliaries
+
+prConstraints :: Constraints -> String
+prConstraints = concat . prConstrs
+
+prMetaSubst :: MetaSubst -> String
+prMetaSubst = concat . prMSubst
+
+prEnv :: Env -> String
+---- prEnv [] = prCurly "" ---- for debugging
+prEnv e = concatMap (\ (x,t) -> prCurly (prt x ++ ":=" ++ prt t)) e
+
+prConstrs :: Constraints -> [String]
+prConstrs = map (\ (v,w) -> prCurly (prt v ++ "<>" ++ prt w))
+
+prMSubst :: MetaSubst -> [String]
+prMSubst = map (\ (m,e) -> prCurly ("?" ++ show m ++ "=" ++ prt e))
+
+prBinds bi = if null bi
+ then []
+ else "\\" ++ concat (intersperse "," (map prValDecl bi)) +++ "-> "
+ where
+ prValDecl (x,t) = prParenth (prt_ x +++ ":" +++ prt_ t)
+
+instance Print Val where
+ prt (VGen i x) = prt x ++ "{-" ++ show i ++ "-}" ---- latter part for debugging
+ prt (VApp u v) = prt u +++ prv1 v
+ prt (VCn mc) = prQIdent_ mc
+ prt (VClos env e) = case e of
+ Meta _ -> prt_ e ++ prEnv env
+ _ -> prt_ e ---- ++ prEnv env ---- for debugging
+ prt VType = "Type"
+
+prv1 v = case v of
+ VApp _ _ -> prParenth $ prt v
+ VClos _ _ -> prParenth $ prt v
+ _ -> prt v
+
+instance Print Atom where
+ prt (AtC f) = prQIdent f
+ prt (AtM i) = prt i
+ prt (AtV i) = prt i
+ prt (AtL s) = prQuotedString s
+ prt (AtI i) = show i
+ prt (AtF i) = show i
+ prt_ (AtC (_,f)) = prt f
+ prt_ a = prt a
+
+prQIdent :: QIdent -> String
+prQIdent (m,f) = prt m ++ "." ++ prt f
+
+prQIdent_ :: QIdent -> String
+prQIdent_ (_,f) = prt f
+
+-- | print terms without qualifications
+prExp :: Term -> String
+prExp e = case e of
+ App f a -> pr1 f +++ pr2 a
+ Abs x b -> "\\" ++ prt x +++ "->" +++ prExp b
+ Prod x a b -> "(\\" ++ prt x +++ ":" +++ prExp a ++ ")" +++ "->" +++ prExp b
+ Q _ c -> prt c
+ QC _ c -> prt c
+ _ -> prt e
+ where
+ pr1 e = case e of
+ Abs _ _ -> prParenth $ prExp e
+ Prod _ _ _ -> prParenth $ prExp e
+ _ -> prExp e
+ pr2 e = case e of
+ App _ _ -> prParenth $ prExp e
+ _ -> pr1 e
+
+-- | option @-strip@ strips qualifications
+prTermOpt :: Options -> Term -> String
+prTermOpt opts = if oElem nostripQualif opts then prt else prExp
+
+-- | to get rid of brackets in the editor
+prRefinement :: Term -> String
+prRefinement t = case t of
+ Q m c -> prQIdent (m,c)
+ QC m c -> prQIdent (m,c)
+ _ -> prt t
+
+prOperSignature :: (QIdent,Type) -> String
+prOperSignature (f, t) = prQIdent f +++ ":" +++ prt t
+
+-- to look up a constant etc in a search tree
+
+lookupIdent :: Ident -> BinTree Ident b -> Err b
+lookupIdent c t = case lookupTree prt c t of
+ Ok v -> return v
+ _ -> prtBad "unknown identifier" c
+
+lookupIdentInfo :: Module Ident f a -> Ident -> Err a
+lookupIdentInfo mo i = lookupIdent i (jments mo)
diff --git a/src/GF/Devel/ReadFiles.hs b/src/GF/Devel/ReadFiles.hs
new file mode 100644
index 000000000..c316a46d5
--- /dev/null
+++ b/src/GF/Devel/ReadFiles.hs
@@ -0,0 +1,356 @@
+----------------------------------------------------------------------
+-- |
+-- 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.Devel.ReadFiles (-- * Heading 1
+ getAllFiles,fixNewlines,ModName,getOptionsFromFile,
+ -- * Heading 2
+ gfcFile,gfFile,gfrFile,isGFC,resModName,isOldFile
+ ) where
+
+import GF.Devel.Arch (selectLater, modifiedFiles, ModTime, getModTime,laterModTime)
+
+import GF.Infra.Option
+import GF.Data.Operations
+import GF.Devel.UseIO
+
+import System
+import Data.Char
+import Control.Monad
+import Data.List
+import System.Directory
+
+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 (prefixPathName 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 = prefixPathName 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 -> (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 $ prefixPathName p f where
+ mk = case st of
+ CSComp -> gfFile
+ CSRead -> gfcFile
+ CSRes -> gfrFile
+
+isGFC :: FilePath -> Bool
+isGFC = (== "gfc") . fileSuffix
+
+gfcFile :: FilePath -> FilePath
+gfcFile = suffixFile "gfc"
+
+gfrFile :: FilePath -> FilePath
+gfrFile = suffixFile "gfr"
+
+gfFile :: FilePath -> FilePath
+gfFile = suffixFile "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 = justModuleName file0 ---- fileBody file0
+ (p,s) <- tryRead name
+ let ((typ,mname),imps) = importsOfFile s
+ let namebody = justFileName 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/GF/Devel/UseIO.hs b/src/GF/Devel/UseIO.hs
new file mode 100644
index 000000000..bd9f47845
--- /dev/null
+++ b/src/GF/Devel/UseIO.hs
@@ -0,0 +1,344 @@
+----------------------------------------------------------------------
+-- |
+-- 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.Devel.UseIO where
+
+import GF.Data.Operations
+import GF.Devel.Arch (prCPU)
+import GF.Infra.Option
+import GF.Today (libdir)
+
+import System.Directory
+import System.IO
+import System.IO.Error
+import System.Environment
+import Control.Monad
+
+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
+
+isPathSep :: Char -> Bool
+isPathSep c = c == ':' || c == ';'
+
+isSep :: Char -> Bool
+isSep c = c == '/' || c == '\\'
+
+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 = prefixPathName 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 (justInitPath 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
+
+-- | first var is lib prefix, second is like class path
+-- | path in environment variable has lower priority
+extendPathEnv :: String -> String -> [FilePath] -> IO [FilePath]
+extendPathEnv lib var ps = do
+ b <- catch (getEnv lib) (const (return libdir)) -- e.g. GF_LIB_PATH
+ s <- catch (getEnv var) (const (return "")) -- e.g. GF_GRAMMAR_PATH
+ let fs = pFilePaths s
+ let ss = ps ++ fs
+ liftM concat $ mapM allSubdirs $ ss ++ [b ++ "/" ++ s | s <- ss]
+
+pFilePaths :: String -> [FilePath]
+pFilePaths s = case break isPathSep s of
+ (f,_:cs) -> f : pFilePaths cs
+ (f,_) -> [f]
+
+getFilePaths :: String -> IO [FilePath]
+getFilePaths s = do
+ let ps = pFilePaths s
+ liftM concat $ mapM allSubdirs ps
+
+getSubdirs :: FilePath -> IO [FilePath]
+getSubdirs p = do
+ fs <- catch (getDirectoryContents p) (const $ return [])
+ fps <- mapM getPermissions (map (prefixPathName p) fs)
+ let ds = [f | (f,p) <- zip fs fps, searchable p, not (take 1 f==".")]
+ return ds
+
+allSubdirs :: FilePath -> IO [FilePath]
+allSubdirs [] = return [[]]
+allSubdirs p = case last p of
+ '*' -> do
+ fs <- getSubdirs (init p)
+ return [prefixPathName (init p) f | f <- fs]
+ _ -> return [p]
+
+prefixPathName :: String -> FilePath -> FilePath
+prefixPathName p f = case f of
+ c:_ | isSep c -> f -- do not prefix [Unix style] absolute paths
+ _ -> case p of
+ "" -> f
+ _ -> p ++ "/" ++ f -- note: / actually works on windows
+
+justInitPath :: FilePath -> FilePath
+justInitPath = reverse . drop 1 . dropWhile (not . isSep) . reverse
+
+nameAndSuffix :: FilePath -> (String,String)
+nameAndSuffix file = case span (/='.') (reverse file) of
+ (_,[]) -> (file,[])
+ (xet,deman) -> if any isSep xet
+ then (file,[]) -- cover cases like "foo.bar/baz"
+ else (reverse $ drop 1 deman,reverse xet)
+
+unsuffixFile, fileBody :: FilePath -> String
+unsuffixFile = fst . nameAndSuffix
+fileBody = unsuffixFile
+
+fileSuffix :: FilePath -> String
+fileSuffix = snd . nameAndSuffix
+
+justFileName :: FilePath -> String
+justFileName = reverse . takeWhile (not . isSep) . reverse
+
+suffixFile :: String -> FilePath -> FilePath
+suffixFile suff file = file ++ "." ++ suff
+
+justModuleName :: FilePath -> String
+justModuleName = fileBody . justFileName
+
+--
+
+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
+
+
+-- | forces verbosity
+putPointEVerb :: Options -> String -> IOE a -> IOE a
+putPointEVerb opts = putPointE (addOption beVerbose opts)
+
+gfLibraryPath = "GF_LIB_PATH"
+
+-- ((do {s <- readFile f; return (return s)}) )
+readFileIOE :: FilePath -> IOE (String)
+readFileIOE f = ioe $ catch (readFileStrict f >>= return . return)
+ (\_ -> return (Bad (reportOn f))) where
+ reportOn f = "File " ++ f ++ " not found."
+
+-- | like readFileIOE but look also in the GF library if file not found
+--
+-- intended semantics: if file is not found, try @\$GF_LIB_PATH\/file@
+-- (even if file is an absolute path, but this should always fail)
+-- it returns not only contents of the file, but also the path used
+--
+-- FIXME: unix-specific, \/ is \\ on Windows
+readFileLibraryIOE :: String -> FilePath -> IOE (FilePath, String)
+readFileLibraryIOE ini f =
+ ioe $ catch ((do {s <- readFileStrict initPath; return (return (initPath,s))}))
+ (\_ -> tryLibrary ini f) where
+ tryLibrary :: String -> FilePath -> IO (Err (FilePath, String))
+ tryLibrary ini f =
+ catch (do {
+ lp <- getLibPath;
+ s <- readFileStrict (lp ++ f);
+ return (return (lp ++ f, s))
+ }) (\_ -> return (Bad (reportOn f)))
+ initPath = addInitFilePath ini f
+ getLibPath :: IO String
+ getLibPath = do {
+ lp <- catch (getEnv gfLibraryPath) (const (return libdir)) ;
+ return (if isSep (last lp) then lp else lp ++ ['/']);
+ }
+ reportOn f = "File " ++ f ++ " not found."
+ libPath ini f = f
+ addInitFilePath ini file = case file of
+ c:_ | isSep c -> file -- absolute path name
+ _ -> ini ++ file -- relative path name
+
+
+-- | example
+koeIOE :: IO ()
+koeIOE = useIOE () $ do
+ s <- ioeIO $ getLine
+ s2 <- ioeErr $ mapM (!? 2) $ words s
+ ioeIO $ putStrLn s2
+
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 23:13:17 +0000