forked from GitHub/gf-core
compiler "gfc" in GF/Devel
This commit is contained in:
aarne
89
src/GF/Devel/Arch.hs
Normal file
89
src/GF/Devel/Arch.hs
Normal file
@@ -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
|
||||
218
src/GF/Devel/Compile.hs
Normal file
218
src/GF/Devel/Compile.hs
Normal file
@@ -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)
|
||||
|
||||
|
||||
20
src/GF/Devel/GFC.hs
Normal file
20
src/GF/Devel/GFC.hs
Normal file
@@ -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."
|
||||
54
src/GF/Devel/GetGrammar.hs
Normal file
54
src/GF/Devel/GetGrammar.hs
Normal file
@@ -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
|
||||
|
||||
471
src/GF/Devel/GrammarToGFCC.hs
Normal file
471
src/GF/Devel/GrammarToGFCC.hs
Normal file
@@ -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)
|
||||
|
||||
233
src/GF/Devel/PrGrammar.hs
Normal file
233
src/GF/Devel/PrGrammar.hs
Normal file
@@ -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)
|
||||
356
src/GF/Devel/ReadFiles.hs
Normal file
356
src/GF/Devel/ReadFiles.hs
Normal file
@@ -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
|
||||
|
||||
344
src/GF/Devel/UseIO.hs
Normal file
344
src/GF/Devel/UseIO.hs
Normal file
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user