From e17235893d36d23733ed0a7485cd040006995aab Mon Sep 17 00:00:00 2001 From: aarne Date: Thu, 21 Feb 2008 08:04:43 +0000 Subject: [PATCH] documenting testgf3 --- src/GF/Devel/Compile/CheckGrammar.hs | 6 +- src/GF/Devel/Compile/Compile.hs | 4 +- src/GF/Devel/Compile/GF.cf | 2 +- src/GF/Devel/Compile/SourceToGF.hs | 1 + src/GF/Devel/Grammar/Compute.hs | 2 +- src/GF/Devel/Grammar/Lookup.hs | 2 +- src/GF/Devel/Infra/ReadFiles.hs | 348 +++++++++++++++++++++++++++ src/GF/Devel/README-testgf3 | 34 +++ 8 files changed, 390 insertions(+), 9 deletions(-) create mode 100644 src/GF/Devel/Infra/ReadFiles.hs create mode 100644 src/GF/Devel/README-testgf3 diff --git a/src/GF/Devel/Compile/CheckGrammar.hs b/src/GF/Devel/Compile/CheckGrammar.hs index 5038c5168..831d0b9b2 100644 --- a/src/GF/Devel/Compile/CheckGrammar.hs +++ b/src/GF/Devel/Compile/CheckGrammar.hs @@ -429,10 +429,8 @@ inferLType gr trm = case trm of QC m ident -> checks [ termWith trm $ checkErr (lookupOperType gr m ident) >>= comp - , - checkErr (lookupOperDef gr m ident) >>= infer - , - prtFail "cannot infer type of canonical constant" trm +-- ,checkErr (lookupOperDef gr m ident) >>= infer +-- ,prtFail "cannot infer type of canonical constant" trm ] Val ty i -> termWith trm $ return ty diff --git a/src/GF/Devel/Compile/Compile.hs b/src/GF/Devel/Compile/Compile.hs index 6edb64703..b636f0fa7 100644 --- a/src/GF/Devel/Compile/Compile.hs +++ b/src/GF/Devel/Compile/Compile.hs @@ -14,7 +14,7 @@ import GF.Devel.Grammar.Construct import GF.Infra.Ident import GF.Devel.Grammar.PrGF ----import GF.Devel.Grammar.Lookup -import GF.Devel.ReadFiles +import GF.Devel.Infra.ReadFiles import GF.Infra.Option ---- import GF.Data.Operations @@ -102,7 +102,7 @@ compileOne opts env@(_,srcgr) file = do -- for compiled gf, read the file and update environment -- also undo common subexp optimization, to enable normal computations - "gfo" -> do + "gfn" -> do sm0 <- putp ("+ reading" +++ file) $ getSourceModule opts file let sm1 = unsubexpModule sm0 sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule srcgr sm1 diff --git a/src/GF/Devel/Compile/GF.cf b/src/GF/Devel/Compile/GF.cf index a0ce1ebb7..3edbdf347 100644 --- a/src/GF/Devel/Compile/GF.cf +++ b/src/GF/Devel/Compile/GF.cf @@ -13,7 +13,7 @@ comment "{-" "-}" ; -- identifiers -position token PIdent ('_')? letter (letter | digit | '_' | '\'')* ; +position token PIdent ('_' | letter) (letter | digit | '_' | '\'')* ; -- the top-level grammar diff --git a/src/GF/Devel/Compile/SourceToGF.hs b/src/GF/Devel/Compile/SourceToGF.hs index f501fd609..64455f907 100644 --- a/src/GF/Devel/Compile/SourceToGF.hs +++ b/src/GF/Devel/Compile/SourceToGF.hs @@ -444,6 +444,7 @@ transExp x = case x of ---- ELin id -> liftM G.LiT $ transIdent id EEqs eqs -> liftM G.Eqs $ mapM transEquation eqs + EData -> return G.EData _ -> Bad $ "translation not yet defined for" +++ printTree x ---- diff --git a/src/GF/Devel/Grammar/Compute.hs b/src/GF/Devel/Grammar/Compute.hs index 6835fdbe1..5e465c160 100644 --- a/src/GF/Devel/Grammar/Compute.hs +++ b/src/GF/Devel/Grammar/Compute.hs @@ -283,7 +283,7 @@ computeTermOpt rec gr = comp where return $ T i cs' T i cs -> do - pty0 <- getTableType i + pty0 <- errIn (prt t) $ getTableType i ptyp <- comp g pty0 case allParamValues gr ptyp of Ok vs -> do diff --git a/src/GF/Devel/Grammar/Lookup.hs b/src/GF/Devel/Grammar/Lookup.hs index 876d60d26..d8747a1e4 100644 --- a/src/GF/Devel/Grammar/Lookup.hs +++ b/src/GF/Devel/Grammar/Lookup.hs @@ -44,7 +44,7 @@ lookupOperType gr m c = do case jform ju of JParam -> return typePType _ -> case jtype ju of - Meta _ -> fail "no type given" + Meta _ -> fail ("no type given to " ++ prIdent m ++ "." ++ prIdent c) ty -> return ty ---- can't be just lookupJField jtype diff --git a/src/GF/Devel/Infra/ReadFiles.hs b/src/GF/Devel/Infra/ReadFiles.hs new file mode 100644 index 000000000..ad1a1ac5e --- /dev/null +++ b/src/GF/Devel/Infra/ReadFiles.hs @@ -0,0 +1,348 @@ +---------------------------------------------------------------------- +-- | +-- 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.gfo@ otherwise. +----------------------------------------------------------------------------- + +module GF.Devel.Infra.ReadFiles (-- * Heading 1 + getAllFiles,fixNewlines,ModName,getOptionsFromFile, + -- * Heading 2 + gfoFile,gfFile,isGFO,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 gfo, or if in env; returns full file path + +data CompStatus = + CSComp -- compile: read gf + | CSRead -- read gfo + | CSEnv -- gfo is in env + | CSEnvR -- also gfr is in env + | CSDont -- don't read at all + | CSRes -- read gfr + deriving (Eq,Show) + +-- for gfo, 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 -gfo + mtgfc <- getModTime $ gfoFile 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 gfo is earlier than a deeper gfo + 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] + + + -- 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 -> gfoFile + CSRes -> gfoFile ---- gfr + +isGFO :: FilePath -> Bool +isGFO = (== "gfn") . fileSuffix + +gfoFile :: FilePath -> FilePath +gfoFile = suffixFile "gfn" + +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 + return (gfoFile name) -- gfo 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/README-testgf3 b/src/GF/Devel/README-testgf3 new file mode 100644 index 000000000..f7ea4b6aa --- /dev/null +++ b/src/GF/Devel/README-testgf3 @@ -0,0 +1,34 @@ +GF3, the next version of GF +Aarne Ranta + + +Version 1: 20/2/2008 + +To compile: + + make testgf3 + +To run: + + testgf3 + +Options: + + -src -- read from source + -doemit -- emit gfn files + +More options (debugging flags): + + -show_gf -- show compiled source module after parsing + -show_extend -- ... after extension + -show_rename -- ... after renaming + -show_typecheck -- ... after type checking + -show_refreshing -- ... after refreshing variables + -show_optimize -- ... after partial evaluation + -show_factorize -- ... after factoring optimization + + -1 -- stop before extending + -2 -- ... renaming + -3 -- ... type checking + -4 -- ... refreshing + -5 -- ... partial evaluation