msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

remove all files that aren't used in GF-3.0

Browse Source
This commit is contained in:
kr.angelov
2008-05-22 11:59:31 +00:00
parent 6394f3ccfb
commit df0c4f81fa
286 changed files with 21 additions and 53176 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1078
src-3.0/GF/Compile/CheckGrammar.hs
View File

File diff suppressed because it is too large Load Diff

401
src-3.0/GF/Compile/Compile.hs
View File

@@ -1,401 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : Compile
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/05 20:02:19 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.45 $
--
-- The top-level compilation chain from source file to gfc\/gfr.
-----------------------------------------------------------------------------
module GF.Compile.Compile (compileModule, compileEnvShSt, compileOne,
CompileEnv, TimedCompileEnv,gfGrammarPathVar,pathListOpts,
getGFEFiles) where
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Infra.Option
import GF.Infra.CompactPrint
import GF.Grammar.PrGrammar
import GF.Compile.Update
import GF.Grammar.Lookup
import GF.Infra.Modules
import GF.Infra.ReadFiles
import GF.Compile.ShellState
import GF.Compile.MkResource
---- import MkUnion
-- the main compiler passes
import GF.Compile.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.Devel.GrammarToGFCC -----
import GF.Devel.OptimizeGF (subexpModule,unsubexpModule)
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.Infra.UseIO
import GF.Text.UTF8 ----
import GF.System.Arch
import Control.Monad
import System.Directory
import System.FilePath
-- | in batch mode: write code in a file
batchCompile f = liftM fst $ compileModule defOpts emptyShellState f
where
defOpts = options [emitCode]
batchCompileOpt f = liftM fst $ compileModule defOpts emptyShellState f
where
defOpts = options [emitCode, optimizeCanon]
batchCompileOld f = compileOld defOpts f
where
defOpts = options [emitCode]
-- | 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 -> ShellState -> FilePath -> IOE TimedCompileEnv
---- IOE (GFC.CanonGrammar, (SourceGrammar,[(String,(FilePath,ModTime))]))
compileModule opts st0 file |
oElem showOld opts ||
elem suff [".cf",".ebnf",".gfm"] = do
let putp = putPointE opts
let putpp = putPointEsil opts
let path = [] ----
grammar1 <- case suff of
".cf" -> putp ("- parsing" +++ suff +++ file) $ getCFGrammar opts file
".ebnf" -> putp ("- parsing" +++ suff +++ file) $ getEBNFGrammar opts file
".gfm" -> putp ("- parsing" +++ suff +++ file) $ getSourceGrammar opts file
_ -> putp ("- parsing old gf" +++ file) $ getOldGrammar opts file
let mods = modules grammar1
let env = compileEnvShSt st0 []
foldM (comp putpp path) env mods
where
suff = takeExtensions file
comp putpp path env sm0 = do
(k',sm,eenv') <- makeSourceModule opts (fst env) sm0
cm <- putpp " generating code... " $ generateModuleCode opts path sm
ft <- getReadTimes file ---
extendCompileEnvInt env (k',sm,cm) eenv' ft
compileModule opts1 st0 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 = dropFileName file
ps0 <- ioeIO $ pathListOpts opts fpath
let ps1 = if (useFileOpt && not useLineOpt)
then (ps0 ++ map (combine fpath) ps0)
else ps0
ps <- ioeIO $ extendPathEnv ps1
let ioeIOIf = if oElem beVerbose opts then ioeIO else (const (return ()))
ioeIOIf $ putStrLn $ "module search path:" +++ show ps ----
let st = st0 --- if useFileOpt then emptyShellState else st0
let rfs = [(m,t) | (m,(_,t)) <- readFiles st]
let file' = if useFileOpt then takeFileName 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
getReadTimes file = do
t <- ioeIO getNowTime
let m = justModuleName file
return $ (m,(file,t)) : [(resModName m,(file,t)) | not (isGFC file)]
compileEnvShSt :: ShellState -> [ModName] -> TimedCompileEnv
compileEnvShSt st fs = ((0,sgr,cgr,eenv),fts) where
cgr = MGrammar [m | m@(i,_) <- modules (canModules st), notInc i]
sgr = MGrammar [m | m@(i,_) <- modules (srcModules st), notIns i]
notInc i = notElem (prt i) $ map dropExtension fs
notIns i = notElem (prt i) $ map dropExtension fs
fts = readFiles st
eenv = evalEnv st
pathListOpts :: Options -> FileName -> IO [InitPath]
pathListOpts opts file = return $ maybe [file] splitInModuleSearchPath $ getOptVal opts pathList
reverseModules (MGrammar ms) = MGrammar $ reverse ms
keepResModules :: Options -> SourceGrammar -> SourceGrammar
keepResModules opts gr =
if oElem retainOpers opts
then MGrammar $ reverse [(i,mi) | (i,mi@(ModMod m)) <- modules gr, isModRes m]
else emptyMGrammar
-- | the environment
type CompileEnv = (Int,SourceGrammar, GFC.CanonGrammar,EEnv)
emptyCompileEnv :: TimedCompileEnv
emptyCompileEnv = ((0,emptyMGrammar,emptyMGrammar,emptyEEnv),[])
extendCompileEnvInt ((_,MGrammar ss, MGrammar cs,_),fts) (k,sm,cm) eenv ft =
return ((k,MGrammar (sm:ss), MGrammar (cm:cs),eenv),ft++fts) --- reverse later
extendCompileEnv e@((k,_,_,_),_) (sm,cm) = extendCompileEnvInt e (k,sm,cm)
extendCompileEnvCanon ((k,s,c,e),fts) cgr eenv ft =
return ((k,s, MGrammar (modules cgr ++ modules c),eenv),ft++fts)
type TimedCompileEnv = (CompileEnv,[(String,(FilePath,ModTime))])
compileOne :: Options -> TimedCompileEnv -> FullPath -> IOE TimedCompileEnv
compileOne opts env@((_,srcgr,cancgr0,eenv),_) file = do
let putp = putPointE opts
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 = takeExtensions file
let path = dropFileName file
let name = dropExtension file
let mos = modules srcgr
case gf of
-- for multilingual canonical gf, just read the file and update environment
".gfcm" -> do
cgr <- putp ("+ reading" +++ file) $ getCanonGrammar file
ft <- getReadTimes file
extendCompileEnvCanon env cgr eenv ft
-- for canonical gf, read the file and update environment, also source env
".gfc" -> do
cm <- putp ("+ reading" +++ file) $ getCanonModule file
let cancgr = updateMGrammar (MGrammar [cm]) cancgr0
sm <- ioeErr $ CG.canon2sourceModule $ unoptimizeCanonMod cancgr $ unSubelimModule cm
ft <- getReadTimes file
extendCompileEnv env (sm, cm) eenv ft
-- for compiled resource, parse and organize, then update environment
".gfr" -> do
sm0 <- putp ("| reading" +++ file) $ getSourceModule opts file
let sm1 = unsubexpModule sm0
sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule mos sm1
---- experiment with not optimizing gfr
---- sm:_ <- putp " optimizing " $ ioeErr $ evalModule mos sm1
let gfc = gfcFile name
cm <- putp ("+ reading" +++ gfc) $ getCanonModule gfc
ft <- getReadTimes file
extendCompileEnv env (sm,cm) eenv ft
-- for gf source, do full compilation
_ -> do
--- hack fix to a bug in ReadFiles with reused concrete
let modu = dropExtension file
b1 <- ioeIO $ doesFileExist file
b2 <- ioeIO $ doesFileExist $ gfrFile modu
if not b1
then if b2
then compileOne opts env $ gfrFile $ modu
else compileOne opts env $ gfcFile $ modu
else do
sm0 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $
getSourceModule opts file
(k',sm,eenv') <- makeSourceModule opts (fst env) sm0
cm <- putpp " generating code... " $ generateModuleCode opts path sm
ft <- getReadTimes file
sm':_ <- case snd sm of
---- ModMod n | isModRes n -> putp " optimizing " $ ioeErr $ evalModule mos sm
_ -> return [sm]
extendCompileEnvInt env (k',sm',cm) eenv' ft
-- | dispatch reused resource at early stage
makeSourceModule :: Options -> CompileEnv ->
SourceModule -> IOE (Int,SourceModule,EEnv)
makeSourceModule opts env@(k,gr,can,eenv) mo@(i,mi) = case mi of
ModMod m -> case mtype m of
MTReuse c -> do
sm <- ioeErr $ makeReuse gr i (extend m) c
let mo2 = (i, ModMod sm)
mos = modules gr
--- putp " type checking reused" $ ioeErr $ showCheckModule mos mo2
return $ (k,mo2,eenv)
{- ---- obsolete
MTUnion ty imps -> do
mo' <- ioeErr $ makeUnion gr i ty imps
compileSourceModule opts env mo'
-}
_ -> compileSourceModule opts env mo
_ -> compileSourceModule opts env mo
where
putp = putPointE opts
compileSourceModule :: Options -> CompileEnv ->
SourceModule -> IOE (Int,SourceModule,EEnv)
compileSourceModule opts env@(k,gr,can,eenv) mo@(i,mi) = do
let putp = putPointE opts
putpp = putPointEsil opts
mos = modules gr
if (oElem showOld opts && oElem emitCode opts)
then do
let (file,out) = (gfFile (prt i), prGrammar (MGrammar [mo]))
putp (" wrote file" +++ file) $ ioeIO $ writeFile file out
else return ()
mo1 <- ioeErr $ rebuildModule mos mo
mo1b <- ioeErr $ extendModule mos mo1
case mo1b of
(_,ModMod n) | not (isCompleteModule n) -> do
return (k,mo1b,eenv) -- 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
(mo4,eenv') <-
---- if oElem "check_only" opts
putpp " optimizing " $ ioeErr $ optimizeModule opts (mos,eenv) mo3r
return (k',mo4,eenv')
where
---- prDebug mo = ioeIO $ putStrLn $ prGrammar $ MGrammar [mo] ---- debug
prDebug mo = ioeIO $ print $ length $ lines $ prGrammar $ MGrammar [mo]
generateModuleCode :: Options -> InitPath -> SourceModule -> IOE GFC.CanonModule
generateModuleCode opts path minfo@(name,info) = do
--- DEPREC
--- if oElem (iOpt "gfcc") opts
--- then ioeIO $ putStrLn $ prGrammar2gfcc minfo
--- else return ()
let pname = path </> prt name
minfo0 <- ioeErr $ redModInfo minfo
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"
minfo' <-
if subs
then ioeErr $ elimSubtermsMod minfo1
else return minfo1
-- for resource, also emit gfr.
--- Also for incomplete, to create timestamped gfc/gfr files
case info of
ModMod m | emitsGFR m && emit && nomulti -> do
let rminfo = if isCompilable info
then subexpModule minfo
else (name, ModMod emptyModule)
let (file,out) = (gfrFile pname, prGrammar (MGrammar [rminfo]))
putp (" wrote file" +++ file) $ ioeIO $ writeFile file $ compactPrint out
_ -> return ()
let encode = case getOptVal opts uniCoding of
Just "utf8" -> encodeUTF8
_ -> id
(file,out) <- do
code <- return $ MkGFC.prCanonModInfo minfo'
return (gfcFile pname, encode code)
if emit && nomulti ---- && isCompilable info
then putp (" wrote file" +++ file) $ ioeIO $ writeFile file out
else putpp ("no need to save module" +++ prt name) $ return ()
return minfo'
where
putp = putPointE opts
putpp = putPointEsil opts
emitsGFR m = isModRes m ---- && isCompilable info
---- isModRes m || (isModCnc m && mstatus m == MSIncomplete)
isCompilable mi = case mi of
ModMod m -> not $ isModCnc m && mstatus m == MSIncomplete
_ -> True
nomulti = not $ oElem makeMulti opts
emit = oElem emitCode opts && not (oElem notEmitCode opts)
-- for old GF: sort into modules, write files, compile as usual
compileOld :: Options -> FilePath -> IOE GFC.CanonGrammar
compileOld opts file = do
let putp = putPointE opts
grammar1 <- putp ("- parsing old gf" +++ file) $ getOldGrammar opts file
files <- mapM writeNewGF $ modules grammar1
((_,_,grammar,_),_) <- foldM (compileOne opts) emptyCompileEnv files
return grammar
writeNewGF :: SourceModule -> IOE FilePath
writeNewGF m@(i,_) = do
let file = gfFile $ prt i
ioeIO $ writeFile file $ prGrammar (MGrammar [m])
ioeIO $ putStrLn $ "wrote file" +++ file
return file
--- this function duplicates a lot of code from compileModule.
--- It does not really belong here either.
-- It selects those .gfe files that a grammar depends on and that
-- are younger than corresponding gf
getGFEFiles :: Options -> FilePath -> IO [FilePath]
getGFEFiles opts1 file = useIOE [] $ 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 = dropFileName file
ps0 <- ioeIO $ pathListOpts opts fpath
let ps1 = if (useFileOpt && not useLineOpt)
then (map (combine fpath) ps0)
else ps0
ps <- ioeIO $ extendPathEnv ps1
let file' = if useFileOpt then takeFileName file else file -- to find file itself
files <- getAllFiles opts ps [] file'
efiles <- ioeIO $ filterM doesFileExist [replaceExtension f "gfe" | f <- files]
es <- ioeIO $ mapM (uncurry selectLater) [(f, init f) | f <- efiles] -- init gfe == gf
return $ filter ((=='e') . last) es

477
src-3.0/GF/Compile/Evaluate.hs
View File

@@ -1,477 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : Evaluate
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/01 15:39:12 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.19 $
--
-- Computation of source terms. Used in compilation and in @cc@ command.
-----------------------------------------------------------------------------
module GF.Compile.Evaluate (appEvalConcrete, EEnv, emptyEEnv) where
import GF.Data.Operations
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Data.Str
import GF.Grammar.PrGrammar
import GF.Infra.Modules
import GF.Infra.Option
import GF.Grammar.Macros
import GF.Grammar.Lookup
import GF.Grammar.Refresh
import GF.Grammar.PatternMatch
import GF.Grammar.Lockfield (isLockLabel) ----
import GF.Grammar.AppPredefined
import qualified Data.Map as Map
import Data.List (nub,intersperse)
import Control.Monad (liftM2, liftM)
import Debug.Trace
data EEnv = EEnv {
computd :: Map.Map (Ident,Ident) FTerm,
temp :: Int
}
emptyEEnv = EEnv Map.empty 0
lookupComputed :: (Ident,Ident) -> STM EEnv (Maybe FTerm)
lookupComputed mc = do
env <- readSTM
return $ Map.lookup mc $ computd env
updateComputed :: (Ident,Ident) -> FTerm -> STM EEnv ()
updateComputed mc t =
updateSTM (\e -> e{computd = Map.insert mc t (computd e)})
getTemp :: STM EEnv Ident
getTemp = do
env <- readSTM
updateSTM (\e -> e{temp = temp e + 1})
return $ identC ("#" ++ show (temp env))
data FTerm =
FTC Term
| FTF (Term -> FTerm)
prFTerm :: Integer -> FTerm -> String
prFTerm i t = case t of
FTC t -> prt t
FTF f -> show i +++ "->" +++ prFTerm (i + 1) (f (EInt i))
term2fterm t = case t of
Abs x b -> FTF (\t -> term2fterm (subst [(x,t)] b))
_ -> FTC t
traceFTerm c ft = ft ----
----trace ("\n" ++ prt c +++ "=" +++ take 60 (prFTerm 0 ft)) ft
fterm2term :: FTerm -> STM EEnv Term
fterm2term t = case t of
FTC t -> return t
FTF f -> do
x <- getTemp
b <- fterm2term $ f (Vr x)
return $ Abs x b
subst g t = case t of
Vr x -> maybe t id $ lookup x g
_ -> composSafeOp (subst g) t
appFTerm :: FTerm -> [Term] -> FTerm
appFTerm ft ts = case (ft,ts) of
(FTF f, x:xs) -> appFTerm (f x) xs
(FTC c, _:_) -> FTC $ foldl App c ts
_ -> ft
apps :: Term -> (Term,[Term])
apps t = case t of
App f a -> (f',xs ++ [a]) where (f',xs) = apps f
_ -> (t,[])
appEvalConcrete gr bt env = appSTM (evalConcrete gr bt) env
evalConcrete :: SourceGrammar -> BinTree Ident Info -> STM EEnv (BinTree Ident Info)
evalConcrete gr mo = mapMTree evaldef mo where
evaldef (f,info) = case info of
CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr ->
evalIn ("\nerror in linearization of function" +++ prt f +++ ":") $
do
pde' <- case pde of
Yes de -> do
liftM yes $ pEval ty de
_ -> return pde
--- ppr' <- liftM yes $ evalPrintname gr c ppr pde'
return $ (f, CncFun mt pde' ppr) -- only cat in type actually needed
_ -> return (f,info)
pEval (context,val) trm = do ---- errIn ("parteval" +++ prt_ trm) $ do
let
vars = map fst context
args = map Vr vars
subst = [(v, Vr v) | v <- vars]
trm1 = mkApp trm args
trm3 <- recordExpand val trm1 >>= comp subst >>= recomp subst
return $ mkAbs vars trm3
---- temporary hack to ascertain full evaluation, because of bug in comp
recomp g t = if notReady t then comp g t else return t
notReady = not . null . redexes
redexes t = case t of
Q _ _ -> return [()]
_ -> collectOp redexes t
recordExpand typ trm = case unComputed typ of
RecType tys -> case trm of
FV rs -> return $ FV [R [assign lab (P r lab) | (lab,_) <- tys] | r <- rs]
_ -> return $ R [assign lab (P trm lab) | (lab,_) <- tys]
_ -> return trm
comp g t = case t of
Q (IC "Predef") _ -> return t ----trace ("\nPredef:\n" ++ prt t) $ return t
Q p c -> do
md <- lookupComputed (p,c)
case md of
Nothing -> do
d <- lookRes (p,c)
updateComputed (p,c) $ traceFTerm c $ term2fterm d
return d
Just d -> fterm2term d >>= comp g
App f a -> case apps t of
{- ----
(h@(QC p c),xs) -> do
xs' <- mapM (comp g) xs
case lookupValueIndex gr ty t of
Ok v -> return v
_ -> return t
-}
(h@(Q p c),xs) | p == IC "Predef" -> do
xs' <- mapM (comp g) xs
(t',b) <- stmErr $ appPredefined (foldl App h xs')
if b then return t' else comp g t'
(h@(Q p c),xs) -> do
xs' <- mapM (comp g) xs
md <- lookupComputed (p,c)
case md of
Just ft -> do
t <- fterm2term $ appFTerm ft xs'
comp g t
Nothing -> do
d <- lookRes (p,c)
let ft = traceFTerm c $ term2fterm d
updateComputed (p,c) ft
t' <- fterm2term $ appFTerm ft xs'
comp g t'
_ -> do
f' <- comp g f
a' <- comp g a
case (f',a') of
(Abs x b,_) -> comp (ext x a' g) b
(QC _ _,_) -> returnC $ App f' a'
(FV fs, _) -> mapM (\c -> comp g (App c a')) fs >>= return . variants
(_, FV as) -> mapM (\c -> comp g (App f' c)) as >>= return . variants
(Alias _ _ d, _) -> comp g (App d a')
(S (T i cs) e,_) -> prawitz g i (flip App a') cs e
_ -> do
(t',b) <- stmErr $ appPredefined (App f' a')
if b then return t' else comp g t'
Vr x -> do
t' <- maybe (prtRaise (
"context" +++ show g +++ ": no value given to variable") x) return $ lookup x g
case t' of
_ | t == t' -> return t
_ -> comp g t'
Abs x b -> do
b' <- comp (ext x (Vr x) g) b
return $ Abs x b'
Let (x,(_,a)) b -> do
a' <- comp g a
comp (ext x a' g) b
Prod x a b -> do
a' <- comp g a
b' <- comp (ext x (Vr x) g) b
return $ Prod x a' b'
P t l | isLockLabel l -> return $ R []
---- a workaround 18/2/2005: take this away and find the reason
---- why earlier compilation destroys the lock field
P t l -> do
t' <- comp g t
case t' of
FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants
R r -> maybe
(prtRaise (prt t' ++ ": no value for label") l) (comp g . snd) $
lookup l r
ExtR a (R b) -> case lookup l b of ----comp g (P (R b) l) of
Just (_,v) -> comp g v
_ -> comp g (P a l)
ExtR (R a) b -> case lookup l a of ----comp g (P (R b) l) of
Just (_,v) -> comp g v
_ -> comp g (P b l)
S (T i cs) e -> prawitz g i (flip P l) cs e
_ -> returnC $ P t' l
S t@(T _ cc) v -> do
v' <- comp g v
case v' of
FV vs -> do
ts' <- mapM (comp g . S t) vs
return $ variants ts'
_ -> case matchPattern cc v' of
Ok (c,g') -> comp (g' ++ g) c
_ | isCan v' -> prtRaise ("missing case" +++ prt v' +++ "in") t
_ -> do
t' <- comp g t
return $ S t' v' -- if v' is not canonical
S t v -> do
t' <- comp g t
v' <- comp g v
case t' of
T _ [(PV IW,c)] -> comp g c --- an optimization
T _ [(PT _ (PV IW),c)] -> comp g c
T _ [(PV z,c)] -> comp (ext z v' g) c --- another optimization
T _ [(PT _ (PV z),c)] -> comp (ext z v' g) c
FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants
V ptyp ts -> do
vs <- stmErr $ allParamValues gr ptyp
ps <- stmErr $ mapM term2patt vs
let cc = zip ps ts
case v' of
FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants
_ -> case matchPattern cc v' of
Ok (c,g') -> comp (g' ++ g) c
_ | isCan v' -> prtRaise ("missing case" +++ prt v' +++ "in") t
_ -> return $ S t' v' -- if v' is not canonical
T _ cc -> case v' of
FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants
_ -> case matchPattern cc v' of
Ok (c,g') -> comp (g' ++ g) c
_ | isCan v' -> prtRaise ("missing case" +++ prt v' +++ "in") t
_ -> return $ S t' v' -- if v' is not canonical
Alias _ _ d -> comp g (S d v')
S (T i cs) e -> prawitz g i (flip S v') cs e
_ -> returnC $ S t' v'
-- normalize away empty tokens
K "" -> return Empty
-- glue if you can
Glue x0 y0 -> do
x <- comp g x0
y <- comp g y0
case (x,y) of
(Alias _ _ d, y) -> comp g $ Glue d y
(x, Alias _ _ d) -> comp g $ Glue x d
(S (T i cs) e, s) -> prawitz g i (flip Glue s) cs e
(s, S (T i cs) e) -> prawitz g i (Glue s) cs e
(_,Empty) -> return x
(Empty,_) -> return y
(K a, K b) -> return $ K (a ++ b)
(_, Alts (d,vs)) -> do
---- (K a, Alts (d,vs)) -> do
let glx = Glue x
comp g $ Alts (glx d, [(glx v,c) | (v,c) <- vs])
(Alts _, ka) -> checks [do
y' <- stmErr $ strsFromTerm ka
---- (Alts _, K a) -> checks [do
x' <- stmErr $ strsFromTerm x -- this may fail when compiling opers
return $ variants [
foldr1 C (map K (str2strings (glueStr v u))) | v <- x', u <- y']
---- foldr1 C (map K (str2strings (glueStr v (str a)))) | v <- x']
,return $ Glue x y
]
(FV ks,_) -> do
kys <- mapM (comp g . flip Glue y) ks
return $ variants kys
(_,FV ks) -> do
xks <- mapM (comp g . Glue x) ks
return $ variants xks
_ -> do
mapM_ checkNoArgVars [x,y]
r <- composOp (comp g) t
returnC r
Alts _ -> do
r <- composOp (comp g) t
returnC r
-- remove empty
C a b -> do
a' <- comp g a
b' <- comp g b
case (a',b') of
(Alts _, K a) -> checks [do
as <- stmErr $ strsFromTerm a' -- this may fail when compiling opers
return $ variants [
foldr1 C (map K (str2strings (plusStr v (str a)))) | v <- as]
,
return $ C a' b'
]
(Empty,_) -> returnC b'
(_,Empty) -> returnC a'
_ -> returnC $ C a' b'
-- reduce free variation as much as you can
FV ts -> mapM (comp g) ts >>= returnC . variants
-- merge record extensions if you can
ExtR r s -> do
r' <- comp g r
s' <- comp g s
case (r',s') of
(Alias _ _ d, _) -> comp g $ ExtR d s'
(_, Alias _ _ d) -> comp g $ Glue r' d
(R rs, R ss) -> stmErr $ plusRecord r' s'
(RecType rs, RecType ss) -> stmErr $ plusRecType r' s'
(_, FV ss) -> liftM FV $ mapM (comp g) [ExtR t u | u <- ss]
_ -> return $ ExtR r' s'
-- case-expand tables
-- if already expanded, don't expand again
T i@(TComp _) cs -> do
-- if there are no variables, don't even go inside
cs' <- {-if (null g) then return cs else-} mapPairsM (comp g) cs
return $ T i cs'
--- this means some extra work; should implement TSh directly
TSh i cs -> comp g $ T i [(p,v) | (ps,v) <- cs, p <- ps]
T i cs -> do
pty0 <- stmErr $ getTableType i
ptyp <- comp g pty0
case allParamValues gr ptyp of
Ok vs -> do
cs' <- mapM (compBranchOpt g) cs
sts <- stmErr $ mapM (matchPattern cs') vs
ts <- mapM (\ (c,g') -> comp (g' ++ g) c) sts
ps <- stmErr $ mapM term2patt vs
let ps' = ps --- PT ptyp (head ps) : tail ps
return $ --- V ptyp ts -- to save space, just course of values
T (TComp ptyp) (zip ps' ts)
_ -> do
cs' <- mapM (compBranch g) cs
return $ T i cs' -- happens with variable types
-- otherwise go ahead
_ -> composOp (comp g) t >>= returnC
lookRes (p,c) = case lookupResDefKind gr p c of
Ok (t,_) | noExpand p -> return t
Ok (t,0) -> comp [] t
Ok (t,_) -> return t
Bad s -> raise s
noExpand p = errVal False $ do
mo <- lookupModMod gr p
return $ case getOptVal (iOpts (flags mo)) useOptimizer of
Just "noexpand" -> True
_ -> False
prtRaise s t = raise (s +++ prt t)
ext x a g = (x,a):g
returnC = return --- . computed
variants ts = case nub ts of
[t] -> t
ts -> FV ts
isCan v = case v of
Con _ -> True
QC _ _ -> True
App f a -> isCan f && isCan a
R rs -> all (isCan . snd . snd) rs
_ -> False
compBranch g (p,v) = do
let g' = contP p ++ g
v' <- comp g' v
return (p,v')
compBranchOpt g c@(p,v) = case contP p of
[] -> return c
_ -> compBranch g c
---- _ -> err (const (return c)) return $ compBranch g c
contP p = case p of
PV x -> [(x,Vr x)]
PC _ ps -> concatMap contP ps
PP _ _ ps -> concatMap contP ps
PT _ p -> contP p
PR rs -> concatMap (contP . snd) rs
PAs x p -> (x,Vr x) : contP p
PSeq p q -> concatMap contP [p,q]
PAlt p q -> concatMap contP [p,q]
PRep p -> contP p
PNeg p -> contP p
_ -> []
prawitz g i f cs e = do
cs' <- mapM (compBranch g) [(p, f v) | (p,v) <- cs]
return $ S (T i cs') e
-- | argument variables cannot be glued
checkNoArgVars :: Term -> STM EEnv Term
checkNoArgVars t = case t of
Vr (IA _) -> raise $ glueErrorMsg $ prt t
Vr (IAV _) -> raise $ glueErrorMsg $ prt t
_ -> composOp checkNoArgVars t
glueErrorMsg s =
"Cannot glue (+) term with run-time variable" +++ s ++ "." ++++
"Use Prelude.bind instead."
stmErr :: Err a -> STM s a
stmErr e = stm (\s -> do
v <- e
return (v,s)
)
evalIn :: String -> STM s a -> STM s a
evalIn msg st = stm $ \s -> case appSTM st s of
Bad e -> Bad $ msg ++++ e
Ok vs -> Ok vs

92
src-3.0/GF/Compile/Flatten.hs
View File

@@ -1,92 +0,0 @@
module Flatten where
import Data.List
-- import GF.Data.Operations
-- (AR 15/3/2006)
--
-- A method for flattening grammars: create many flat rules instead of
-- a few deep ones. This is generally better for parsins.
-- The rules are obtained as follows:
-- 1. write a config file tellinq which constants are variables: format 'c : C'
-- 2. generate a list of trees with their types: format 't : T'
-- 3. for each such tree, form a fun rule 'fun fui : X -> Y -> T' and a lin
-- rule 'lin fui x y = t' where x:X,y:Y is the list of variables in t, as
-- found in the config file.
-- 4. You can go on and produce def or transfer rules similar to the lin rules
-- except for the keyword.
--
-- So far this module is used outside gf. You can e.g. generate a list of
-- trees by 'gt', write it in a file, and then in ghci call
-- flattenGrammar <Config> <Trees> <OutFile>
type Ident = String ---
type Term = String ---
type Rule = String ---
type Config = [(Ident,Ident)]
flattenGrammar :: FilePath -> FilePath -> FilePath -> IO ()
flattenGrammar conff tf out = do
conf <- readFile conff >>= return . lines
ts <- readFile tf >>= return . lines
writeFile out $ mkFlatten conf ts
mkFlatten :: [String] -> [String] -> String
mkFlatten conff = unlines . concatMap getOne . zip [1..] where
getOne (k,t) = let (x,y) = mkRules conf ("fu" ++ show k) t in [x,y]
conf = getConfig conff
mkRules :: Config -> Ident -> Term -> (Rule,Rule)
mkRules conf f t = (fun f ty, lin f (takeWhile (/=':') t)) where
args = mkArgs conf ts
ty = concat [a ++ " -> " | a <- map snd args] ++ val
(ts,val) = let tt = lexTerm t in (init tt,last tt)
--- f = identV t
fun c a = unwords [" fun", c, ":",a,";"]
lin c a = unwords $ [" lin", c] ++ map fst args ++ ["=",a,";"]
mkArgs :: Config -> [Ident] -> [(Ident,Ident)]
mkArgs conf ids = [(x,ty) | x <- ids, Just ty <- [lookup x conf]]
mkIdent :: Term -> Ident
mkIdent = map mkChar where
mkChar c = case c of
'(' -> '6'
')' -> '9'
' ' -> '_'
_ -> c
-- to get just the identifiers
lexTerm :: String -> [String]
lexTerm ss = case lex ss of
[([c],ws)] | isSpec c -> lexTerm ws
[(w@(_:_),ws)] -> w : lexTerm ws
_ -> []
where
isSpec = flip elem "();:"
getConfig :: [String] -> Config
getConfig = map getOne . filter (not . null) where
getOne line = case lexTerm line of
v:c:_ -> (v,c)
ex = putStrLn fs where
fs =
mkFlatten
["man_N : N",
"sleep_V : V"
]
["PredVP (DefSg man_N) (UseV sleep_V) : Cl",
"PredVP (DefPl man_N) (UseV sleep_V) : Cl"
]
{-
-- result of ex
fun fu1 : N -> V -> Cl ;
lin fu1 man_N sleep_V = PredVP (DefSg man_N) (UseV sleep_V) ;
fun fu2 : N -> V -> Cl ;
lin fu2 man_N sleep_V = PredVP (DefPl man_N) (UseV sleep_V) ;
-}

146
src-3.0/GF/Compile/GetGrammar.hs
View File

@@ -1,146 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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.Compile.GetGrammar (
getSourceModule, getSourceGrammar,
getOldGrammar, getCFGrammar, getEBNFGrammar
) where
import GF.Data.Operations
import qualified GF.Source.ErrM as E
import GF.Infra.UseIO
import GF.Grammar.Grammar
import GF.Infra.Modules
import GF.Grammar.PrGrammar
import qualified GF.Source.AbsGF as A
import GF.Source.SourceToGrammar
---- import Macros
---- import Rename
import GF.Text.UTF8 ----
import GF.Infra.Option
--- import Custom
import GF.Source.ParGF
import qualified GF.Source.LexGF as L
import GF.CF.CF (rules2CF)
import GF.CF.PPrCF
import GF.CF.CFtoGrammar
import GF.CF.EBNF
import GF.Infra.ReadFiles ----
import Data.Char (toUpper)
import Data.List (nub)
import qualified Data.ByteString.Char8 as BS
import Control.Monad (foldM)
import System (system)
import System.FilePath
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
string0 <- readFileIOE file
let string = case getOptVal opts uniCoding of
Just "utf8" -> decodeUTF8 string0
_ -> string0
let tokens = myLexer (BS.pack string)
mo1 <- ioeErr $ pModDef tokens
ioeErr $ transModDef mo1
getSourceGrammar :: Options -> FilePath -> IOE SourceGrammar
getSourceGrammar opts file = do
string <- readFileIOE file
let tokens = myLexer (BS.pack string)
gr1 <- ioeErr $ pGrammar tokens
ioeErr $ transGrammar gr1
-- for old GF format with includes
getOldGrammar :: Options -> FilePath -> IOE SourceGrammar
getOldGrammar opts file = do
defs <- parseOldGrammarFiles file
let g = A.OldGr A.NoIncl defs
let name = takeFileName file
ioeErr $ transOldGrammar opts name g
parseOldGrammarFiles :: FilePath -> IOE [A.TopDef]
parseOldGrammarFiles file = do
putStrLnE $ "reading grammar of old format" +++ file
(_, g) <- getImports "" ([],[]) file
return g -- now we can throw away includes
where
getImports oldInitPath (oldImps, oldG) f = do
(path,s) <- readFileLibraryIOE oldInitPath f
if not (elem path oldImps)
then do
(imps,g) <- parseOldGrammar path
foldM (getImports (initFilePath path)) (path : oldImps, g ++ oldG) imps
else
return (oldImps, oldG)
parseOldGrammar :: FilePath -> IOE ([FilePath],[A.TopDef])
parseOldGrammar file = do
putStrLnE $ "reading old file" +++ file
s <- ioeIO $ readFileIf file
A.OldGr incl topdefs <- ioeErr $ pOldGrammar $ oldLexer $ fixNewlines s
includes <- ioeErr $ transInclude incl
return (includes, topdefs)
----
-- | To resolve the new reserved words:
-- change them by turning the final letter to upper case.
--- There is a risk of clash.
oldLexer :: String -> [L.Token]
oldLexer = map change . L.tokens . BS.pack where
change t = case t of
(L.PT p (L.TS s)) | elem s newReservedWords ->
(L.PT p (L.TV (init s ++ [toUpper (last s)])))
_ -> t
getCFGrammar :: Options -> FilePath -> IOE SourceGrammar
getCFGrammar opts file = do
let mo = takeWhile (/='.') file
s <- ioeIO $ readFileIf file
let files = case words (concat (take 1 (lines s))) of
"--":"include":fs -> fs
_ -> []
ss <- ioeIO $ mapM readFileIf files
cfs <- ioeErr $ mapM (pCF mo) $ s:ss
defs <- return $ cf2grammar $ rules2CF $ concat cfs
let g = A.OldGr A.NoIncl defs
--- let ma = justModuleName file
--- let mc = 'C':ma ---
--- let opts' = addOptions (options [useAbsName ma, useCncName mc]) opts
ioeErr $ transOldGrammar opts file g
getEBNFGrammar :: Options -> FilePath -> IOE SourceGrammar
getEBNFGrammar opts file = do
let mo = takeWhile (/='.') file
s <- ioeIO $ readFileIf file
defs <- ioeErr $ pEBNFasGrammar s
let g = A.OldGr A.NoIncl defs
--- let ma = justModuleName file
--- let mc = 'C':ma ---
--- let opts' = addOptions (options [useAbsName ma, useCncName mc]) opts
ioeErr $ transOldGrammar opts file g

293
src-3.0/GF/Compile/GrammarToCanon.hs
View File

@@ -1,293 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : GrammarToCanon
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/11 23:24:33 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.23 $
--
-- Code generator from optimized GF source code to GFC.
-----------------------------------------------------------------------------
module GF.Compile.GrammarToCanon (showGFC,
redModInfo, redQIdent
) where
import GF.Data.Operations
import GF.Data.Zipper
import GF.Infra.Option
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Grammar.PrGrammar
import GF.Infra.Modules
import GF.Grammar.Macros
import qualified GF.Canon.AbsGFC as G
import qualified GF.Canon.GFC as C
import GF.Canon.MkGFC
---- import Alias
import qualified GF.Canon.PrintGFC as P
import Control.Monad
import Data.List (nub,sortBy)
-- compilation of optimized grammars to canonical GF. AR 5/10/2001 -- 12/5/2003
-- | This is the top-level function printing a gfc file
showGFC :: SourceGrammar -> String
showGFC = err id id . liftM (P.printTree . grammar2canon) . redGrammar
-- | any grammar, first trying without dependent types
-- abstract syntax without dependent types
redGrammar :: SourceGrammar -> Err C.CanonGrammar
redGrammar (MGrammar gr) = liftM MGrammar $ mapM redModInfo $ filter active gr where
active (_,m) = case typeOfModule m of
MTInterface -> False
_ -> True
redModInfo :: (Ident, SourceModInfo) -> Err (Ident, C.CanonModInfo)
redModInfo (c,info) = do
c' <- redIdent c
info' <- case info of
ModMod m -> do
let isIncompl = not $ isCompleteModule m
(e,os) <- if isIncompl then return ([],[]) else redExtOpen m ----
flags <- mapM redFlag $ flags m
(a,mt0) <- case mtype m of
MTConcrete a -> do
a' <- redIdent a
return (a', MTConcrete a')
MTAbstract -> return (c',MTAbstract) --- c' not needed
MTResource -> return (c',MTResource) --- c' not needed
MTInterface -> return (c',MTResource) ---- not needed
MTInstance _ -> return (c',MTResource) --- c' not needed
MTTransfer x y -> return (c',MTTransfer (om x) (om y)) --- c' not needed
--- this generates empty GFC reosurce for interface and incomplete
let js = if isIncompl then emptyBinTree else jments m
mt = mt0 ---- if isIncompl then MTResource else mt0
defss <- mapM (redInfo a) $ tree2list $ js
let defs0 = concat defss
let lgh = length defs0
defs <- return $ sorted2tree $ defs0 -- sorted, but reduced
let flags1 = if isIncompl then C.flagIncomplete : flags else flags
let flags' = G.Flg (identC "modulesize") (identC ("n"++show lgh)) : flags1
return $ ModMod $ Module mt MSComplete flags' e os defs
return (c',info')
where
redExtOpen m = do
e' <- case extends m of
es -> mapM (liftM inheritAll . redIdent) es
os' <- mapM (\o -> case o of
OQualif q _ i -> liftM (OSimple q) (redIdent i)
_ -> prtBad "cannot translate unqualified open in" c) $ opens m
return (e',nub os')
om = oSimple . openedModule --- normalizing away qualif
redInfo :: Ident -> (Ident,Info) -> Err [(Ident,C.Info)]
redInfo am (c,info) = errIn ("translating definition of" +++ prt c) $ do
c' <- redIdent c
case info of
AbsCat (Yes cont) pfs -> do
let fs = case pfs of
Yes ts -> [(m,c) | Q m c <- ts]
_ -> []
returns c' $ C.AbsCat cont fs
AbsFun (Yes typ) pdf -> do
let df = case pdf of
Yes t -> t -- definition or "data"
_ -> Eqs [] -- primitive notion
returns c' $ C.AbsFun typ df
AbsTrans t ->
returns c' $ C.AbsTrans t
ResParam (Yes (ps,_)) -> do
ps' <- mapM redParam ps
returns c' $ C.ResPar ps'
CncCat pty ptr ppr -> case (pty,ptr,ppr) of
(Yes ty, Yes (Abs _ t), Yes pr) -> do
ty' <- redCType ty
trm' <- redCTerm t
pr' <- redCTerm pr
return [(c', C.CncCat ty' trm' pr')]
_ -> prtBad ("cannot reduce rule for") c
CncFun mt ptr ppr -> case (mt,ptr,ppr) of
(Just (cat,_), Yes trm, Yes pr) -> do
cat' <- redIdent cat
(xx,body,_) <- termForm trm
xx' <- mapM redArgvar xx
body' <- errIn (prt body) $ redCTerm body ---- debug
pr' <- redCTerm pr
return [(c',C.CncFun (G.CIQ am cat') xx' body' pr')]
_ -> prtBad ("cannot reduce rule" +++ show info +++ "for") c ---- debug
AnyInd s b -> do
b' <- redIdent b
returns c' $ C.AnyInd s b'
_ -> return [] --- retain some operations
where
returns f i = return [(f,i)]
redQIdent :: QIdent -> Err G.CIdent
redQIdent (m,c) = return $ G.CIQ m c
redIdent :: Ident -> Err Ident
redIdent x
| isWildIdent x = return $ identC "h_" --- needed in declarations
| otherwise = return $ identC $ prt x ---
redFlag :: Option -> Err G.Flag
redFlag (Opt (f,[x])) = return $ G.Flg (identC f) (identC x)
redFlag o = Bad $ "cannot reduce option" +++ prOpt o
redDecl :: Decl -> Err G.Decl
redDecl (x,a) = liftM2 G.Decl (redIdent x) (redType a)
redType :: Type -> Err G.Exp
redType = redTerm
redTerm :: Type -> Err G.Exp
redTerm t = return $ rtExp t
-- to normalize records and record types
sortByFst :: Ord a => [(a,b)] -> [(a,b)]
sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
-- resource
redParam :: Param -> Err G.ParDef
redParam (c,cont) = do
c' <- redIdent c
cont' <- mapM (redCType . snd) cont
return $ G.ParD c' cont'
redArgvar :: Ident -> Err G.ArgVar
redArgvar x = case x of
IA (x,i) -> return $ G.A (identC x) (toInteger i)
IAV (x,b,i) -> return $ G.AB (identC x) (toInteger b) (toInteger i)
_ -> Bad $ "cannot reduce" +++ show x +++ "as argument variable"
redLindef :: Term -> Err G.Term
redLindef t = case t of
Abs x b -> redCTerm b ---
_ -> redCTerm t
redCType :: Type -> Err G.CType
redCType t = case t of
RecType lbs -> do
let (ls,ts) = unzip lbs
ls' = map redLabel ls
ts' <- mapM redCType ts
return $ G.RecType $ map (uncurry G.Lbg) $ sortByFst $ zip ls' ts'
Table p v -> liftM2 G.Table (redCType p) (redCType v)
Q m c -> liftM G.Cn $ redQIdent (m,c)
QC m c -> liftM G.Cn $ redQIdent (m,c)
App (Q (IC "Predef") (IC "Ints")) (EInt n) -> return $ G.TInts (toInteger n)
Sort "Str" -> return $ G.TStr
Sort "Tok" -> return $ G.TStr
_ -> prtBad "cannot reduce to canonical the type" t
redCTerm :: Term -> Err G.Term
redCTerm t = case t of
Vr x -> checkAgain
(liftM G.Arg $ redArgvar x)
(liftM G.LI $ redIdent x) --- for parametrize optimization
App _ s -> do -- only constructor applications can remain
(_,c,xx) <- termForm t
xx' <- mapM redCTerm xx
case c of
QC p c -> liftM2 G.Par (redQIdent (p,c)) (return xx')
Q (IC "Predef") (IC "error") -> fail $ "error: " ++ stringFromTerm s
_ -> prtBad "expected constructor head instead of" c
Q p c -> liftM G.I (redQIdent (p,c))
QC p c -> liftM2 G.Par (redQIdent (p,c)) (return [])
R rs -> do
let (ls,tts) = unzip rs
ls' = map redLabel ls
ts <- mapM (redCTerm . snd) tts
return $ G.R $ map (uncurry G.Ass) $ sortByFst $ zip ls' ts
RecType [] -> return $ G.R [] --- comes out in parsing
P tr l -> do
tr' <- redCTerm tr
return $ G.P tr' (redLabel l)
PI tr l _ -> redCTerm $ P tr l -----
T i cs -> do
ty <- getTableType i
ty' <- redCType ty
let (ps,ts) = unzip cs
ps' <- mapM redPatt ps
ts' <- mapM redCTerm ts
return $ G.T ty' $ map (uncurry G.Cas) $ zip (map singleton ps') ts'
TSh i cs -> do
ty <- getTableType i
ty' <- redCType ty
let (pss,ts) = unzip cs
pss' <- mapM (mapM redPatt) pss
ts' <- mapM redCTerm ts
return $ G.T ty' $ map (uncurry G.Cas) $ zip pss' ts'
V ty ts -> do
ty' <- redCType ty
ts' <- mapM redCTerm ts
return $ G.V ty' ts'
S u v -> liftM2 G.S (redCTerm u) (redCTerm v)
K s -> return $ G.K (G.KS s)
EInt i -> return $ G.EInt i
EFloat i -> return $ G.EFloat i
C u v -> liftM2 G.C (redCTerm u) (redCTerm v)
FV ts -> liftM G.FV $ mapM redCTerm ts
--- Ready ss -> return $ G.Ready [redStr ss] --- obsolete
Alts (d,vs) -> do ---
d' <- redCTermTok d
vs' <- mapM redVariant vs
return $ G.K $ G.KP d' vs'
Empty -> return $ G.E
--- Strs ss -> return $ G.Strs [s | K s <- ss] ---
---- Glue obsolete in canon, should not occur here
Glue x y -> redCTerm (C x y)
_ -> Bad ("cannot reduce term" +++ prt t)
redPatt :: Patt -> Err G.Patt
redPatt p = case p of
PP m c ps -> liftM2 G.PC (redQIdent (m,c)) (mapM redPatt ps)
PR rs -> do
let (ls,tts) = unzip rs
ls' = map redLabel ls
ts <- mapM redPatt tts
return $ G.PR $ map (uncurry G.PAss) $ sortByFst $ zip ls' ts
PT _ q -> redPatt q
PInt i -> return $ G.PI i
PFloat i -> return $ G.PF i
PV x -> liftM G.PV $ redIdent x --- for parametrize optimization
_ -> prtBad "cannot reduce pattern" p
redLabel :: Label -> G.Label
redLabel (LIdent s) = G.L $ identC s
redLabel (LVar i) = G.LV $ toInteger i
redVariant :: (Term, Term) -> Err G.Variant
redVariant (v,c) = do
v' <- redCTermTok v
c' <- redCTermTok c
return $ G.Var v' c'
redCTermTok :: Term -> Err [String]
redCTermTok t = case t of
K s -> return [s]
Empty -> return []
C a b -> liftM2 (++) (redCTermTok a) (redCTermTok b)
Strs ss -> return [s | K s <- ss] ---
_ -> prtBad "cannot get strings from term" t

154
src-3.0/GF/Compile/MkConcrete.hs
View File

@@ -1,154 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : MkConcrete
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date:
-- > CVS $Author:
-- > CVS $Revision:
--
-- Compile a gfe file into a concrete syntax by using the parser on a resource grammar.
-----------------------------------------------------------------------------
module GF.Compile.MkConcrete (mkConcretes) where
import GF.Grammar.Values (Tree,tree2exp)
import GF.Grammar.PrGrammar (prt_,prModule)
import GF.Grammar.Grammar --- (Term(..),SourceModule)
import GF.Grammar.Macros (composSafeOp, composOp, record2subst, zIdent)
import GF.Compile.ShellState --(firstStateGrammar,stateGrammarWords)
import GF.Compile.PGrammar (pTerm,pTrm)
import GF.Compile.Compile
import GF.Compile.PrOld (stripTerm)
import GF.Compile.GetGrammar
import GF.API
import GF.API.IOGrammar
import qualified GF.Embed.EmbedAPI as EA
import GF.Data.Operations
import GF.Infra.UseIO
import GF.Infra.Option
import GF.Infra.Modules
import GF.Infra.ReadFiles
import GF.System.Arch
import GF.UseGrammar.Treebank
import System.Directory
import System.FilePath
import Data.Char
import Control.Monad
import Data.List
-- translate strings into lin rules by parsing in a resource
-- grammar. AR 2/6/2005
-- Format of rule (on one line):
-- lin F x y = in C "ssss" ;
-- Format of resource path (on first line):
-- --# -resource=PATH
-- Other lines are copied verbatim.
-- A sequence of files can be processed with the same resource without
-- rebuilding the grammar and parser.
-- notice: we use a hand-crafted lexer and parser in order to preserve
-- the layout and comments in the rest of the file.
mkConcretes :: Options -> [FilePath] -> IO ()
mkConcretes opts files = do
ress <- mapM getResPath files
let grps = groupBy (\a b -> fst a == fst b) $
sortBy (\a b -> compare (fst a) (fst b)) $ zip ress files
mapM_ (mkCncGroups opts) [(rp,map snd gs) | gs@((rp,_):_) <- grps]
mkCncGroups opts0 ((res,path),files) = do
putStrLnFlush $ "Going to preprocess examples in " ++ unwords files
putStrLn $ "Compiling resource " ++ res
let opts = addOptions (options [beSilent,pathList path]) opts0
let treebank = oElem (iOpt "treebank") opts
resf <- useIOE res $ do
(fp,_) <- readFileLibraryIOE "" res
return fp
egr <- appIOE $ shellStateFromFiles opts emptyShellState resf
(parser,morpho) <- if treebank then do
tb <- err (\_ -> error $ "no treebank of name" +++ path)
return
(egr >>= flip findTreebank (zIdent path))
return (\_ -> flip (,) "Not in treebank" . map pTrm . lookupTreebank tb,
isWordInTreebank tb)
else do
gr <- err (\s -> putStrLn s >> error "resource grammar rejected")
(return . firstStateGrammar) egr
return
(\cat s ->
errVal ([],"No parse") $
optParseArgErrMsg (options [newFParser, firstCat cat, beVerbose]) gr s >>=
(\ (ts,e) -> return (map tree2exp ts, e)) ,
isKnownWord gr)
putStrLn "Building parser"
mapM_ (mkConcrete parser morpho) files
type Parser = String -> String -> ([Term],String)
type Morpho = String -> Bool
getResPath :: FilePath -> IO (String,String)
getResPath file = do
s <- liftM lines $ readFileIf file
case filter (not . all isSpace) s of
res:path:_ | is "resource" res && is "path" path -> return (val res, val path)
res:path:_ | is "resource" res && is "treebank" path -> return (val res, val path)
res:_ | is "resource" res -> return (val res, "")
_ -> error
"expected --# -resource=FILE and optional --# -path=PATH or --# -treebank=IDENT"
where
val = dropWhile (isSpace) . tail . dropWhile (not . (=='='))
is tag s = case words s of
"--#":w:_ -> isPrefixOf ('-':tag) w
_ -> False
mkConcrete :: Parser -> Morpho -> FilePath -> IO ()
mkConcrete parser morpho file = do
src <- appIOE (getSourceModule noOptions file) >>= err error return
let (src',msgs) = mkModule parser morpho src
let out = addExtension (justModuleName file) "gf"
writeFile out $ "-- File generated by GF from " ++ file
appendFile out "\n"
appendFile out (prModule src')
appendFile out "{-\n"
appendFile out $ unlines $ filter (not . null) msgs
appendFile out "-}\n"
mkModule :: Parser -> Morpho -> SourceModule -> (SourceModule,[String])
mkModule parser morpho (name,src) = case src of
ModMod m@(Module mt st fs me ops js) ->
let js1 = jments m
(js2,msgs) = err error id $ appSTM (mapMTree mkInfo js1) []
mod2 = ModMod $ Module mt st fs me ops $ js2
in ((name,mod2), msgs)
where
mkInfo ni@(name,info) = case info of
CncFun mt (Yes trm) ppr -> do
trm' <- mkTrm trm
return (name, CncFun mt (Yes trm') ppr)
_ -> return ni
where
mkTrm t = case t of
Example (P _ cat) s -> parse cat s t
Example (Vr cat) s -> parse cat s t
_ -> composOp mkTrm t
parse cat s t = case parser (prt_ cat) s of
(tr:[], _) -> do
updateSTM ((("PARSED in" +++ prt_ name) : s : [prt_ tr]) ++)
return $ stripTerm tr
(tr:trs,_) -> do
updateSTM ((("AMBIGUOUS in" +++ prt_ name) : s : map prt_ trs) ++)
return $ stripTerm tr
([],ms) -> do
updateSTM ((("NO PARSE in" +++ prt_ name) : s : ms : [morph s]) ++)
return t
morph s = case [w | w <- words s, not (morpho w)] of
[] -> ""
ws -> "unknown words: " ++ unwords ws

128
src-3.0/GF/Compile/MkResource.hs
View File

@@ -1,128 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : MkResource
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/30 21:08:14 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.14 $
--
-- Compile a gfc module into a "reuse" gfr resource, interface, or instance.
-----------------------------------------------------------------------------
module GF.Compile.MkResource (makeReuse) where
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Infra.Modules
import GF.Grammar.Macros
import GF.Grammar.Lockfield
import GF.Grammar.PrGrammar
import GF.Data.Operations
import Control.Monad
-- | extracting resource r from abstract + concrete syntax.
-- AR 21\/8\/2002 -- 22\/6\/2003 for GF with modules
makeReuse :: SourceGrammar -> Ident -> [(Ident,MInclude Ident)] ->
MReuseType Ident -> Err SourceRes
makeReuse gr r me mrc = do
flags <- return [] --- no flags are passed: they would not make sense
case mrc of
MRResource c -> do
(ops,jms) <- mkFull True c
return $ Module MTResource MSComplete flags me ops jms
MRInstance c a -> do
(ops,jms) <- mkFull False c
return $ Module (MTInstance a) MSComplete flags me ops jms
MRInterface c -> do
mc <- lookupModule gr c
(ops,jms) <- case mc of
ModMod m -> case mtype m of
MTAbstract -> liftM ((,) (opens m)) $
mkResDefs True False gr r c me
(extend m) (jments m) emptyBinTree
_ -> prtBad "expected abstract to be the type of" c
_ -> prtBad "expected abstract to be the type of" c
return $ Module MTInterface MSIncomplete flags me ops jms
where
mkFull hasT c = do
mc <- lookupModule gr c
case mc of
ModMod m -> case mtype m of
MTConcrete a -> do
ma <- lookupModule gr a
jmsA <- case ma of
ModMod m' -> return $ jments m'
_ -> prtBad "expected abstract to be the type of" a
liftM ((,) (opens m)) $
mkResDefs hasT True gr r a me (extend m) jmsA (jments m)
_ -> prtBad "expected concrete to be the type of" c
_ -> prtBad "expected concrete to be the type of" c
-- | the first Boolean indicates if the type needs be given
-- the second Boolean indicates if the definition needs be given
mkResDefs :: Bool -> Bool ->
SourceGrammar -> Ident -> Ident ->
[(Ident,MInclude Ident)] -> [(Ident,MInclude Ident)] ->
BinTree Ident Info -> BinTree Ident Info ->
Err (BinTree Ident Info)
mkResDefs hasT isC gr r a mext maext abs cnc = mapMTree (mkOne a maext) abs where
ifTyped = yes --- if hasT then yes else const nope --- needed for TC
ifCompl = if isC then yes else const nope
doIf b t = if b then t else return typeType -- latter value not used
mkOne a mae (f,info) = case info of
AbsCat _ _ -> do
typ <- doIf isC $ err (const (return defLinType)) return $ look cnc f
typ' <- doIf isC $ lockRecType f typ
return (f, ResOper (ifTyped typeType) (ifCompl typ'))
AbsFun (Yes typ0) _ -> do
trm <- doIf isC $ look cnc f
testErr (not (isHardType typ0))
("cannot build reuse for function" +++ prt f +++ ":" +++ prt typ0)
typ <- redirTyp True a mae typ0
cat <- valCat typ
trm' <- doIf isC $ unlockRecord (snd cat) trm
return (f, ResOper (ifTyped typ) (ifCompl trm'))
AnyInd b n -> do
mo <- lookupModMod gr n
info' <- lookupInfo mo f
mkOne n (extend mo) (f,info')
look cnc f = do
info <- lookupTree prt f cnc
case info of
CncCat (Yes ty) _ _ -> return ty
CncCat _ _ _ -> return defLinType
CncFun _ (Yes tr) _ -> return tr
AnyInd _ n -> do
mo <- lookupModMod gr n
t <- look (jments mo) f
redirTyp False n (extend mo) t
_ -> prtBad "not enough information to reuse" f
-- type constant qualifications changed from abstract to resource
redirTyp always a mae ty = case ty of
Q _ c | always -> return $ Q r c
Q n c | n == a || [n] == map fst mae -> return $ Q r c ---- FIX for non-singleton exts
_ -> composOp (redirTyp always a mae) ty
-- | no reuse for functions of HO\/dep types
isHardType t = case t of
Prod x a b -> not (isWild x) || isHardType a || isHardType b
App _ _ -> True
_ -> False
where
isWild x = isWildIdent x || prt x == "h_" --- produced by transl from canon

83
src-3.0/GF/Compile/MkUnion.hs
View File

@@ -1,83 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : MkUnion
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:21:39 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.7 $
--
-- building union of modules.
-- AR 1\/3\/2004 --- OBSOLETE 15\/9\/2004 with multiple inheritance
-----------------------------------------------------------------------------
module GF.Compile.MkUnion (makeUnion) where
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Infra.Modules
import GF.Grammar.Macros
import GF.Grammar.PrGrammar
import GF.Data.Operations
import GF.Infra.Option
import Data.List
import Control.Monad
makeUnion :: SourceGrammar -> Ident -> ModuleType Ident -> [(Ident,[Ident])] ->
Err SourceModule
makeUnion gr m ty imps = do
ms <- mapM (lookupModMod gr . fst) imps
typ <- return ty ---- getTyp ms
ext <- getExt [i | Just i <- map extends ms]
ops <- return $ nub $ concatMap opens ms
flags <- return $ concatMap flags ms
js <- liftM (buildTree . concat) $ mapM getJments imps
return $ (m, ModMod (Module typ MSComplete flags ext ops js))
where
getExt es = case es of
[] -> return Nothing
i:is -> if all (==i) is then return (Just i)
else Bad "different extended modules in union forbidden"
getJments (i,fs) = do
m <- lookupModMod gr i
let js = jments m
if null fs
then
return (map (unqual i) $ tree2list js)
else do
ds <- mapM (flip justLookupTree js) fs
return $ map (unqual i) $ zip fs ds
unqual i (f,d) = curry id f $ case d of
AbsCat pty pts -> AbsCat (qualCo pty) (qualPs pts)
AbsFun pty pt -> AbsFun (qualP pty) (qualP pt)
AbsTrans t -> AbsTrans $ qual t
ResOper pty pt -> ResOper (qualP pty) (qualP pt)
CncCat pty pt pp -> CncCat (qualP pty) (qualP pt) (qualP pp)
CncFun mp pt pp -> CncFun (qualLin mp) (qualP pt) (qualP pp) ---- mp
ResParam (Yes ps) -> ResParam (yes (map qualParam ps))
ResValue pty -> ResValue (qualP pty)
_ -> d
where
qualP pt = case pt of
Yes t -> yes $ qual t
_ -> pt
qualPs pt = case pt of
Yes ts -> yes $ map qual ts
_ -> pt
qualCo pco = case pco of
Yes co -> yes $ [(x,qual t) | (x,t) <- co]
_ -> pco
qual t = case t of
Q m c | m==i -> Cn c
QC m c | m==i -> Cn c
_ -> composSafeOp qual t
qualParam (p,co) = (p,[(x,qual t) | (x,t) <- co])
qualLin (Just (c,(co,t))) = (Just (c,([(x,qual t) | (x,t) <- co], qual t)))
qualLin Nothing = Nothing

294
src-3.0/GF/Compile/NewRename.hs
View File

@@ -1,294 +0,0 @@
----------------------------------------------------------------------
-- |
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:21:41 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.6 $
--
-- AR 14\/5\/2003
--
-- The top-level function 'renameGrammar' does several things:
--
-- - extends each module symbol table by indirections to extended module
--
-- - changes unqualified and as-qualified imports to absolutely qualified
--
-- - goes through the definitions and resolves names
--
-- Dependency analysis between modules has been performed before this pass.
-- Hence we can proceed by @fold@ing "from left to right".
-----------------------------------------------------------------------------
module GF.Compile.NewRename (renameSourceTerm, renameModule) where
import GF.Grammar.Grammar
import GF.Grammar.Values
import GF.Infra.Modules
import GF.Infra.Ident
import GF.Grammar.Macros
import GF.Grammar.PrGrammar
import GF.Grammar.AppPredefined
import GF.Grammar.Lookup
import GF.Compile.Extend
import GF.Data.Operations
import Control.Monad
-- | this gives top-level access to renaming term input in the cc command
renameSourceTerm :: SourceGrammar -> Ident -> Term -> Err Term
renameSourceTerm g m t = do
mo <- lookupErr m (modules g)
let status = (modules g,(m,mo)) --- <- buildStatus g m mo
renameTerm status [] t
-- | this is used in the compiler, separately for each module
renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule]
renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod of
ModMod m@(Module mt st fs me ops js) -> do
let js1 = jments m
let status = (ms, (name, mod))
js2 <- mapMTree (renameInfo status) js1
let mod2 = ModMod $ Module mt st fs me (map forceQualif ops) js2
return $ (name,mod2) : ms
type Status = ([SourceModule],SourceModule) --- (StatusTree, [(OpenSpec Ident, StatusTree)])
--- type StatusTree = BinTree (Ident,StatusInfo)
--- type StatusInfo = Ident -> Term
lookupStatusInfo :: Ident -> SourceModule -> Err Term
lookupStatusInfo c (q,ModMod m) = do
i <- lookupTree prt c $ jments m
return $ case i of
AbsFun _ (Yes EData) -> QC q c
ResValue _ -> QC q c
ResParam _ -> QC q c
AnyInd True n -> QC n c --- should go further?
AnyInd False n -> Q n c
_ -> Q q c
lookupStatusInfo c (q,_) = prtBad "ModMod expected for" q
lookupStatusInfoMany :: [SourceModule] -> Ident -> Err Term
lookupStatusInfoMany (m:ms) c = case lookupStatusInfo c m of
Ok v -> return v
_ -> lookupStatusInfoMany ms c
lookupStatusInfoMany [] x =
prtBad "renaming failed to find unqualified constant" x
---- should also give error if stg is found in more than one module
renameIdentTerm :: Status -> Term -> Err Term
renameIdentTerm env@(imps,act@(_,ModMod this)) t =
errIn ("atomic term" +++ prt t +++ "given" +++ unwords (map (prt . fst) qualifs)) $
case t of
Vr c -> do
f <- err (predefAbs c) return $ lookupStatusInfoMany openeds c
return $ f
Cn c -> do
f <- lookupStatusInfoMany openeds c
return $ f
Q m' c | m' == cPredef {- && isInPredefined c -} -> return t
Q m' c -> do
m <- lookupErr m' qualifs
f <- lookupStatusInfo c m
return $ f
QC m' c | m' == cPredef {- && isInPredefined c -} -> return t
QC m' c -> do
m <- lookupErr m' qualifs
f <- lookupStatusInfo c m
return $ f
_ -> return t
where
openeds = act : [(m,st) | OSimple _ m <- opens this, Just st <- [lookup m imps]]
qualifs =
[(m, (n,st)) | OQualif _ m n <- opens this, Just st <- [lookup n imps]]
++
[(m, (m,st)) | OSimple _ m <- opens this, Just st <- [lookup m imps]]
-- qualif is always possible
-- this facility is mainly for BWC with GF1: you need not import PredefAbs
predefAbs c s = case c of
IC "Int" -> return $ Q cPredefAbs cInt
IC "String" -> return $ Q cPredefAbs cString
_ -> Bad s
-- | would it make sense to optimize this by inlining?
renameIdentPatt :: Status -> Patt -> Err Patt
renameIdentPatt env p = do
let t = patt2term p
t' <- renameIdentTerm env t
term2patt t'
{- deprec !
info2status :: Maybe Ident -> (Ident,Info) -> (Ident,StatusInfo)
info2status mq (c,i) = (c, case i of
AbsFun _ (Yes EData) -> maybe Con QC mq
ResValue _ -> maybe Con QC mq
ResParam _ -> maybe Con QC mq
AnyInd True m -> maybe Con (const (QC m)) mq
AnyInd False m -> maybe Cn (const (Q m)) mq
_ -> maybe Cn Q mq
)
tree2status :: OpenSpec Ident -> BinTree (Ident,Info) -> BinTree (Ident,StatusInfo)
tree2status o = case o of
OSimple _ i -> mapTree (info2status (Just i))
OQualif _ i j -> mapTree (info2status (Just j))
buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Err Status
buildStatus gr c mo = let mo' = self2status c mo in case mo of
ModMod m -> do
let gr1 = MGrammar $ (c,mo) : modules gr
ops = [OSimple OQNormal e | e <- allExtendsPlus gr1 c] ++ allOpens m
mods <- mapM (lookupModule gr1 . openedModule) ops
let sts = map modInfo2status $ zip ops mods
return $ if isModCnc m
then (NT, reverse sts) -- the module itself does not define any names
else (mo',reverse sts) -- so the empty ident is not needed
modInfo2status :: (OpenSpec Ident,SourceModInfo) -> (OpenSpec Ident, StatusTree)
modInfo2status (o,i) = (o,case i of
ModMod m -> tree2status o (jments m)
)
self2status :: Ident -> SourceModInfo -> StatusTree
self2status c i = mapTree (info2status (Just c)) js where -- qualify internal
js = case i of
ModMod m
| isModTrans m -> sorted2tree $ filter noTrans $ tree2list $ jments m
| otherwise -> jments m
noTrans (_,d) = case d of -- to enable other than transfer js in transfer module
AbsTrans _ -> False
_ -> True
-}
forceQualif o = case o of
OSimple q i -> OQualif q i i
OQualif q _ i -> OQualif q i i
renameInfo :: Status -> (Ident,Info) -> Err (Ident,Info)
renameInfo status (i,info) = errIn ("renaming definition of" +++ prt i) $
liftM ((,) i) $ case info of
AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco)
(renPerh (mapM rent) pfs)
AbsFun pty ptr -> liftM2 AbsFun (ren pty) (ren ptr)
AbsTrans f -> liftM AbsTrans (rent f)
ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr)
ResParam pp -> liftM ResParam (renPerh (mapM (renameParam status)) pp)
ResValue t -> liftM ResValue (ren t)
CncCat pty ptr ppr -> liftM3 CncCat (ren pty) (ren ptr) (ren ppr)
CncFun mt ptr ppr -> liftM2 (CncFun mt) (ren ptr) (ren ppr)
_ -> return info
where
ren = renPerh rent
rent = renameTerm status []
renPerh ren pt = case pt of
Yes t -> liftM Yes $ ren t
_ -> return pt
renameTerm :: Status -> [Ident] -> Term -> Err Term
renameTerm env vars = ren vars where
ren vs trm = case trm of
Abs x b -> liftM (Abs x) (ren (x:vs) b)
Prod x a b -> liftM2 (Prod x) (ren vs a) (ren (x:vs) b)
Typed a b -> liftM2 Typed (ren vs a) (ren vs b)
Vr x
| elem x vs -> return trm
| otherwise -> renid trm
Cn _ -> renid trm
Con _ -> renid trm
Q _ _ -> renid trm
QC _ _ -> renid trm
Eqs eqs -> liftM Eqs $ mapM (renameEquation env vars) eqs
T i cs -> do
i' <- case i of
TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source
_ -> return i
liftM (T i') $ mapM (renCase vs) cs
Let (x,(m,a)) b -> do
m' <- case m of
Just ty -> liftM Just $ ren vs ty
_ -> return m
a' <- ren vs a
b' <- ren (x:vs) b
return $ Let (x,(m',a')) b'
P t@(Vr r) l -- for constant t we know it is projection
| elem r vs -> return trm -- var proj first
| otherwise -> case renid (Q r (label2ident l)) of -- qualif second
Ok t -> return t
_ -> liftM (flip P l) $ renid t -- const proj last
_ -> composOp (ren vs) trm
renid = renameIdentTerm env
renCase vs (p,t) = do
(p',vs') <- renpatt p
t' <- ren (vs' ++ vs) t
return (p',t')
renpatt = renamePattern env
-- | vars not needed in env, since patterns always overshadow old vars
renamePattern :: Status -> Patt -> Err (Patt,[Ident])
renamePattern env patt = case patt of
PC c ps -> do
c' <- renameIdentTerm env $ Cn c
psvss <- mapM renp ps
let (ps',vs) = unzip psvss
case c' of
QC p d -> return (PP p d ps', concat vs)
Q p d -> return (PP p d ps', concat vs) ---- should not happen
_ -> prtBad "unresolved pattern" c' ---- (PC c ps', concat vs)
---- PP p c ps -> (PP p c ps',concat vs') where (ps',vs') = unzip $ map renp ps
PV x -> case renid patt of
Ok p -> return (p,[])
_ -> return (patt, [x])
PR r -> do
let (ls,ps) = unzip r
psvss <- mapM renp ps
let (ps',vs') = unzip psvss
return (PR (zip ls ps'), concat vs')
_ -> return (patt,[])
where
renp = renamePattern env
renid = renameIdentPatt env
renameParam :: Status -> (Ident, Context) -> Err (Ident, Context)
renameParam env (c,co) = do
co' <- renameContext env co
return (c,co')
renameContext :: Status -> Context -> Err Context
renameContext b = renc [] where
renc vs cont = case cont of
(x,t) : xts
| isWildIdent x -> do
t' <- ren vs t
xts' <- renc vs xts
return $ (x,t') : xts'
| otherwise -> do
t' <- ren vs t
let vs' = x:vs
xts' <- renc vs' xts
return $ (x,t') : xts'
_ -> return cont
ren = renameTerm b
-- | vars not needed in env, since patterns always overshadow old vars
renameEquation :: Status -> [Ident] -> Equation -> Err Equation
renameEquation b vs (ps,t) = do
(ps',vs') <- liftM unzip $ mapM (renamePattern b) ps
t' <- renameTerm b (concat vs' ++ vs) t
return (ps',t')

49
src-3.0/GF/Compile/NoParse.hs
View File

@@ -1,49 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : NoParse
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/14 16:03:41 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.1 $
--
-- Probabilistic abstract syntax. AR 30\/10\/2005
--
-- (c) Aarne Ranta 2005 under GNU GPL
--
-- Contents: decide what lin rules no parser is generated.
-- Usually a list of noparse idents from 'i -boparse=file'.
-----------------------------------------------------------------------------
module GF.Compile.NoParse (
NoParse -- = Ident -> Bool
,getNoparseFromFile -- :: Opts -> IO NoParse
,doParseAll -- :: NoParse
) where
import GF.Infra.Ident
import GF.Data.Operations
import GF.Infra.Option
type NoParse = (Ident -> Bool)
doParseAll :: NoParse
doParseAll = const False
getNoparseFromFile :: Options -> FilePath -> IO NoParse
getNoparseFromFile opts file = do
let f = maybe file id $ getOptVal opts noparseFile
s <- readFile f
let tree = buildTree $ flip zip (repeat ()) $ concat $ map getIgnores $ lines s
tree `seq` return $ igns tree
where
igns tree i = isInBinTree i tree
-- where
getIgnores s = case dropWhile (/="--#") (words s) of
_:"noparse":fs -> map identC fs
_ -> []

300
src-3.0/GF/Compile/Optimize.hs
View File

@@ -1,300 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : Optimize
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/09/16 13:56:13 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.18 $
--
-- Top-level partial evaluation for GF source modules.
-----------------------------------------------------------------------------
module GF.Compile.Optimize (optimizeModule) where
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Infra.Modules
import GF.Grammar.PrGrammar
import GF.Grammar.Macros
import GF.Grammar.Lookup
import GF.Grammar.Refresh
import GF.Grammar.Compute
import GF.Compile.BackOpt
import GF.Compile.CheckGrammar
import GF.Compile.Update
import GF.Compile.Evaluate
import GF.Data.Operations
import GF.Infra.CheckM
import GF.Infra.Option
import Control.Monad
import Data.List
import Debug.Trace
-- conditional trace
prtIf :: (Print a) => Bool -> a -> a
prtIf b t = if b then trace (" " ++ prt t) t else t
-- experimental evaluation, option to import
oEval = iOpt "eval"
-- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.
-- only do this for resource: concrete is optimized in gfc form
optimizeModule :: Options -> ([(Ident,SourceModInfo)],EEnv) ->
(Ident,SourceModInfo) -> Err ((Ident,SourceModInfo),EEnv)
optimizeModule opts mse@(ms,eenv) mo@(_,mi) = case mi of
ModMod m0@(Module mt st fs me ops js) |
st == MSComplete && isModRes m0 && not (oElem oEval oopts)-> do
(mo1,_) <- evalModule oopts mse mo
let
mo2 = case optim of
"parametrize" -> shareModule paramOpt mo1 -- parametrization and sharing
"values" -> shareModule valOpt mo1 -- tables as courses-of-values
"share" -> shareModule shareOpt mo1 -- sharing of branches
"all" -> shareModule allOpt mo1 -- first parametrize then values
"none" -> mo1 -- no optimization
_ -> mo1 -- none; default for src
return (mo2,eenv)
_ -> evalModule oopts mse mo
where
oopts = addOptions opts (iOpts (flagsModule mo))
optim = maybe "all" id $ getOptVal oopts useOptimizer
evalModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> (Ident,SourceModInfo) ->
Err ((Ident,SourceModInfo),EEnv)
evalModule oopts (ms,eenv) mo@(name,mod) = case mod of
ModMod m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of
_ | isModRes m0 && not (oElem oEval oopts) -> do
let deps = allOperDependencies name js
ids <- topoSortOpers deps
MGrammar (mod' : _) <- foldM evalOp gr ids
return $ (mod',eenv)
MTConcrete a | oElem oEval oopts -> do
(js0,eenv') <- appEvalConcrete gr js eenv
js' <- mapMTree (evalCncInfo oopts gr name a) js0 ---- <- gr0 6/12/2005
return $ ((name, ModMod (Module mt st fs me ops js')),eenv')
MTConcrete a -> do
js' <- mapMTree (evalCncInfo oopts gr name a) js ---- <- gr0 6/12/2005
return $ ((name, ModMod (Module mt st fs me ops js')),eenv)
_ -> return $ ((name,mod),eenv)
_ -> return $ ((name,mod),eenv)
where
gr0 = MGrammar $ ms
gr = MGrammar $ (name,mod) : ms
evalOp g@(MGrammar ((_, ModMod m) : _)) i = do
info <- lookupTree prt i $ jments m
info' <- evalResInfo oopts gr (i,info)
return $ updateRes g name i info'
-- | only operations need be compiled in a resource, and this is local to each
-- definition since the module is traversed in topological order
evalResInfo :: Options -> SourceGrammar -> (Ident,Info) -> Err Info
evalResInfo oopts gr (c,info) = case info of
ResOper pty pde -> eIn "operation" $ do
pde' <- case pde of
Yes de | optres -> liftM yes $ comp de
_ -> return pde
return $ ResOper pty pde'
_ -> return info
where
comp = if optres then computeConcrete gr else computeConcreteRec gr
eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
optim = maybe "all" id $ getOptVal oopts useOptimizer
optres = case optim of
"noexpand" -> False
_ -> True
evalCncInfo ::
Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err (Ident,Info)
evalCncInfo opts gr cnc abs (c,info) = do
seq (prtIf (oElem beVerbose opts) c) $ return ()
errIn ("optimizing" +++ prt c) $ case info of
CncCat ptyp pde ppr -> do
pde' <- case (ptyp,pde) of
(Yes typ, Yes de) ->
liftM yes $ pEval ([(varStr, typeStr)], typ) de
(Yes typ, Nope) ->
liftM yes $ mkLinDefault gr typ >>= partEval noOptions gr ([(varStr, typeStr)],typ)
(May b, Nope) ->
return $ May b
_ -> return pde -- indirection
ppr' <- liftM yes $ evalPrintname gr c ppr (yes $ K $ prt c)
return (c, CncCat ptyp pde' ppr')
CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr ->
eIn ("linearization in type" +++ prt (mkProd (cont,val,[])) ++++ "of function") $ do
pde' <- case pde of
Yes de | notNewEval -> do
liftM yes $ pEval ty de
_ -> return pde
ppr' <- liftM yes $ evalPrintname gr c ppr pde'
return $ (c, CncFun mt pde' ppr') -- only cat in type actually needed
_ -> return (c,info)
where
pEval = partEval opts gr
eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
notNewEval = not (oElem oEval opts)
-- | the main function for compiling linearizations
partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term
partEval opts gr (context, val) trm = errIn ("parteval" +++ prt_ trm) $ do
let vars = map fst context
args = map Vr vars
subst = [(v, Vr v) | v <- vars]
trm1 = mkApp trm args
trm3 <- if globalTable
then etaExpand subst trm1 >>= outCase subst
else etaExpand subst trm1
return $ mkAbs vars trm3
where
globalTable = oElem showAll opts --- i -all
comp g t = {- refreshTerm t >>= -} computeTerm gr g t
etaExpand su t = do
t' <- comp su t
case t' of
R _ | rightType t' -> comp su t' --- return t' wo noexpand...
_ -> recordExpand val t' >>= comp su
-- don't eta expand records of right length (correct by type checking)
rightType t = case (t,val) of
(R rs, RecType ts) -> length rs == length ts
_ -> False
outCase subst t = do
pts <- getParams context
let (args,ptyps) = unzip $ filter (flip occur t . fst) pts
if null args
then return t
else do
let argtyp = RecType $ tuple2recordType ptyps
let pvars = map (Vr . zIdent . prt) args -- gets eliminated
patt <- term2patt $ R $ tuple2record $ pvars
let t' = replace (zip args pvars) t
t1 <- comp subst $ T (TTyped argtyp) [(patt, t')]
return $ S t1 $ R $ tuple2record args
--- notice: this assumes that all lin types follow the "old JFP style"
getParams = liftM concat . mapM getParam
getParam (argv,RecType rs) = return
[(P (Vr argv) lab, ptyp) | (lab,ptyp) <- rs, not (isLinLabel lab)]
---getParam (_,ty) | ty==typeStr = return [] --- in lindef
getParam (av,ty) =
Bad ("record type expected not" +++ prt ty +++ "for" +++ prt av)
--- all lin types are rec types
replace :: [(Term,Term)] -> Term -> Term
replace reps trm = case trm of
-- this is the important case
P _ _ -> maybe trm id $ lookup trm reps
_ -> composSafeOp (replace reps) trm
occur t trm = case trm of
-- this is the important case
P _ _ -> t == trm
S x y -> occur t y || occur t x
App f x -> occur t x || occur t f
Abs _ f -> occur t f
R rs -> any (occur t) (map (snd . snd) rs)
T _ cs -> any (occur t) (map snd cs)
C x y -> occur t x || occur t y
Glue x y -> occur t x || occur t y
ExtR x y -> occur t x || occur t y
FV ts -> any (occur t) ts
V _ ts -> any (occur t) ts
Let (_,(_,x)) y -> occur t x || occur t y
_ -> False
-- here we must be careful not to reduce
-- variants {{s = "Auto" ; g = N} ; {s = "Wagen" ; g = M}}
-- {s = variants {"Auto" ; "Wagen"} ; g = variants {N ; M}} ;
recordExpand :: Type -> Term -> Err Term
recordExpand typ trm = case unComputed typ of
RecType tys -> case trm of
FV rs -> return $ FV [R [assign lab (P r lab) | (lab,_) <- tys] | r <- rs]
_ -> return $ R [assign lab (P trm lab) | (lab,_) <- tys]
_ -> return trm
-- | auxiliaries for compiling the resource
mkLinDefault :: SourceGrammar -> Type -> Err Term
mkLinDefault gr typ = do
case unComputed typ of
RecType lts -> mapPairsM mkDefField lts >>= (return . Abs varStr . R . mkAssign)
_ -> prtBad "linearization type must be a record type, not" typ
where
mkDefField typ = case unComputed typ of
Table p t -> do
t' <- mkDefField t
let T _ cs = mkWildCases t'
return $ T (TWild p) cs
Sort "Str" -> return $ Vr varStr
QC q p -> lookupFirstTag gr q p
RecType r -> do
let (ls,ts) = unzip r
ts' <- mapM mkDefField ts
return $ R $ [assign l t | (l,t) <- zip ls ts']
_ | isTypeInts typ -> return $ EInt 0 -- exists in all as first val
_ -> prtBad "linearization type field cannot be" typ
-- | Form the printname: if given, compute. If not, use the computed
-- lin for functions, cat name for cats (dispatch made in evalCncDef above).
--- We cannot use linearization at this stage, since we do not know the
--- defaults we would need for question marks - and we're not yet in canon.
evalPrintname :: SourceGrammar -> Ident -> MPr -> Perh Term -> Err Term
evalPrintname gr c ppr lin =
case ppr of
Yes pr -> comp pr
_ -> case lin of
Yes t -> return $ K $ clean $ prt $ oneBranch t ---- stringFromTerm
_ -> return $ K $ prt c ----
where
comp = computeConcrete gr
oneBranch t = case t of
Abs _ b -> oneBranch b
R (r:_) -> oneBranch $ snd $ snd r
T _ (c:_) -> oneBranch $ snd c
V _ (c:_) -> oneBranch c
FV (t:_) -> oneBranch t
C x y -> C (oneBranch x) (oneBranch y)
S x _ -> oneBranch x
P x _ -> oneBranch x
Alts (d,_) -> oneBranch d
_ -> t
--- very unclean cleaner
clean s = case s of
'+':'+':' ':cs -> clean cs
'"':cs -> clean cs
c:cs -> c: clean cs
_ -> s

77
src-3.0/GF/Compile/PGrammar.hs
View File

@@ -1,77 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : PGrammar
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/25 10:27:12 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.8 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Compile.PGrammar (pTerm, pTrm, pTrms,
pMeta, pzIdent,
string2ident
) where
---import LexGF
import GF.Source.ParGF
import GF.Source.SourceToGrammar (transExp)
import GF.Grammar.Grammar
import GF.Infra.Ident
import qualified GF.Canon.AbsGFC as A
import qualified GF.Canon.GFC as G
import GF.Compile.GetGrammar
import GF.Grammar.Macros
import GF.Grammar.MMacros
import GF.Data.Operations
import qualified Data.ByteString.Char8 as BS
pTerm :: String -> Err Term
pTerm s = do
e <- pExp $ myLexer (BS.pack s)
transExp e
pTrm :: String -> Term
pTrm = errVal (vr (zIdent "x")) . pTerm ---
pTrms :: String -> [Term]
pTrms = map pTrm . sep [] where
sep t cs = case cs of
',' : cs2 -> reverse t : sep [] cs2
c : cs2 -> sep (c:t) cs2
_ -> [reverse t]
pTrm' :: String -> [Term]
pTrm' = err (const []) singleton . pTerm
pMeta :: String -> Integer
pMeta _ = 0 ---
pzIdent :: String -> Ident
pzIdent = zIdent
{-
string2formsAndTerm :: String -> ([Term],Term)
string2formsAndTerm s = case s of
'[':_:_ -> case span (/=']') s of
(x,_:y) -> (pTrms (tail x), pTrm y)
_ -> ([],pTrm s)
_ -> ([], pTrm s)
-}
string2ident :: String -> Err Ident
string2ident s = return $ string2var s
{-
-- reads the Haskell datatype
readGrammar :: String -> Err GrammarST
readGrammar s = case [x | (x,t) <- reads s, ("","") <- lex t] of
[x] -> return x
[] -> Bad "no parse of Grammar"
_ -> Bad "ambiguous parse of Grammar"
-}

84
src-3.0/GF/Compile/PrOld.hs
View File

@@ -1,84 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : PrOld
-- Maintainer : GF
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:21:44 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.8 $
--
-- a hack to print gf2 into gf1 readable files
-- Works only for canonical grammars, printed into GFC. Otherwise we would have
-- problems with qualified names.
-- --- printnames are not preserved, nor are lindefs
-----------------------------------------------------------------------------
module GF.Compile.PrOld (printGrammarOld, stripTerm) where
import GF.Grammar.PrGrammar
import GF.Canon.CanonToGrammar
import qualified GF.Canon.GFC as GFC
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Grammar.Macros
import GF.Infra.Modules
import qualified GF.Source.PrintGF as P
import GF.Source.GrammarToSource
import Data.List
import GF.Data.Operations
import GF.Infra.UseIO
printGrammarOld :: GFC.CanonGrammar -> String
printGrammarOld gr = err id id $ do
as0 <- mapM canon2sourceModule [im | im@(_,ModMod m) <- modules gr, isModAbs m]
cs0 <- mapM canon2sourceModule
[im | im@(_,ModMod m) <- modules gr, isModCnc m || isModRes m]
as1 <- return $ concatMap stripInfo $ concatMap (tree2list . js . snd) as0
cs1 <- return $ concatMap stripInfo $ concatMap (tree2list . js . snd) cs0
return $ unlines $ map prj $ srt as1 ++ srt cs1
where
js (ModMod m) = jments m
srt = sortBy (\ (i,_) (j,_) -> compare i j)
prj ii = P.printTree $ trAnyDef ii
stripInfo :: (Ident,Info) -> [(Ident,Info)]
stripInfo (c,i) = case i of
AbsCat (Yes co) (Yes fs) -> rc $ AbsCat (Yes (stripContext co)) nope
AbsFun (Yes ty) (Yes tr) -> rc $ AbsFun (Yes (stripTerm ty)) (Yes(stripTerm tr))
AbsFun (Yes ty) _ -> rc $ AbsFun (Yes (stripTerm ty)) nope
ResParam (Yes (ps,m)) -> rc $ ResParam (Yes ([(c,stripContext co) | (c,co)<- ps],Nothing))
CncCat (Yes ty) _ _ -> rc $
CncCat (Yes (stripTerm ty)) nope nope
CncFun _ (Yes tr) _ -> rc $ CncFun Nothing (Yes (stripTerm tr)) nope
_ -> []
where
rc j = [(c,j)]
stripContext co = [(x, stripTerm t) | (x,t) <- co]
stripTerm :: Term -> Term
stripTerm t = case t of
Q _ c -> Vr c
QC _ c -> Vr c
T ti cs -> T ti' [(stripPattern p, stripTerm c) | (p,c) <- cs] where
ti' = case ti of
TTyped ty -> TTyped $ stripTerm ty
TComp ty -> TComp $ stripTerm ty
TWild ty -> TWild $ stripTerm ty
_ -> ti
---- R [] -> EInt 8 --- GF 1.2 parser doesn't accept empty records
---- RecType [] -> Cn (zIdent "Int") ---
_ -> composSafeOp stripTerm t
stripPattern p = case p of
PC c [] -> PV c
PP _ c [] -> PV c
PC c ps -> PC c (map stripPattern ps)
PP _ c ps -> PC c (map stripPattern ps)
PR lps -> PR [(l, stripPattern p) | (l,p) <- lps]
PT t p -> PT (stripTerm t) (stripPattern p)
_ -> p

568
src-3.0/GF/Compile/ShellState.hs
View File

@@ -1,568 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : ShellState
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/14 16:03:41 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.53 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Compile.ShellState where
import GF.Data.Operations
import GF.Canon.GFC
import GF.Canon.AbsGFC
import GF.GFCC.CId
--import GF.GFCC.DataGFCC(mkGFCC)
import GF.GFCC.Macros (lookFCFG)
import GF.Canon.CanonToGFCC
import GF.Grammar.Macros
import GF.Grammar.MMacros
import GF.Canon.Look
import GF.Canon.Subexpressions
import GF.Grammar.LookAbs
import GF.Compile.ModDeps
import GF.Compile.Evaluate
import qualified GF.Infra.Modules as M
import qualified GF.Grammar.Grammar as G
import qualified GF.Grammar.PrGrammar as P
import GF.CF.CF
import GF.CF.CFIdent
import GF.CF.CanonToCF
import GF.UseGrammar.Morphology
import GF.Probabilistic.Probabilistic
import GF.Compile.NoParse
import GF.Infra.Option
import GF.Infra.Ident
import GF.Infra.UseIO (justModuleName)
import GF.System.Arch (ModTime)
import qualified Transfer.InterpreterAPI as T
import GF.Formalism.FCFG
import qualified GF.OldParsing.ConvertGrammar as CnvOld -- OBSOLETE
import qualified GF.Conversion.GFC as Cnv
import qualified GF.Conversion.SimpleToFCFG as FCnv
import qualified GF.Parsing.GFC as Prs
import Control.Monad (mplus)
import Data.List (nub,nubBy)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
-- AR 11/11/2001 -- 17/6/2003 (for modules) ---- unfinished
-- | multilingual state with grammars and options
data ShellState = ShSt {
abstract :: Maybe Ident , -- ^ pointer to actual abstract, if not empty st
concrete :: Maybe Ident , -- ^ pointer to primary concrete
concretes :: [((Ident,Ident),Bool)], -- ^ list of all concretes, and whether active
canModules :: CanonGrammar , -- ^ compiled abstracts and concretes
srcModules :: G.SourceGrammar , -- ^ saved resource modules
cfs :: [(Ident,CF)] , -- ^ context-free grammars (small, no parameters, very over-generating)
abstracts :: [(Ident,[Ident])], -- ^ abstracts and their associated concretes
mcfgs :: [(Ident, Cnv.MGrammar)], -- ^ MCFG, converted according to Ljunglöf (2004, ch 3)
fcfgs :: [(Ident, FGrammar)], -- ^ FCFG, optimized MCFG by Krasimir Angelov
cfgs :: [(Ident, Cnv.CGrammar)], -- ^ CFG, converted from mcfg
-- (large, with parameters, no-so overgenerating)
pInfos :: [(Ident, Prs.PInfo)], -- ^ parsing information (compiled mcfg&cfg grammars)
morphos :: [(Ident,Morpho)], -- ^ morphologies
treebanks :: [(Ident,Treebank)], -- ^ treebanks
probss :: [(Ident,Probs)], -- ^ probability distributions
gloptions :: Options, -- ^ global options
readFiles :: [(String,(FilePath,ModTime))],-- ^ files read
absCats :: [(G.Cat,(G.Context,
[(G.Fun,G.Type)],
[((G.Fun,Int),G.Type)]))], -- ^ cats, (their contexts,
-- functions to them,
-- functions on them)
statistics :: [Statistics], -- ^ statistics on grammars
transfers :: [(Ident,T.Env)], -- ^ transfer modules
evalEnv :: EEnv -- ^ evaluation environment
}
type Treebank = Map.Map String [String] -- string, trees
actualConcretes :: ShellState -> [((Ident,Ident),Bool)]
actualConcretes sh = nub [((c,c),b) |
Just a <- [abstract sh],
((c,_),_) <- concretes sh, ----concretesOfAbstract sh a,
let b = True -----
]
concretesOfAbstract :: ShellState -> Ident -> [Ident]
concretesOfAbstract sh a = [c | (b,cs) <- abstracts sh, b == a, c <- cs]
data Statistics =
StDepTypes Bool -- ^ whether there are dependent types
| StBoundVars [G.Cat] -- ^ which categories have bound variables
--- -- etc
deriving (Eq,Ord)
emptyShellState :: ShellState
emptyShellState = ShSt {
abstract = Nothing,
concrete = Nothing,
concretes = [],
canModules = M.emptyMGrammar,
srcModules = M.emptyMGrammar,
cfs = [],
abstracts = [],
mcfgs = [],
fcfgs = [],
cfgs = [],
pInfos = [],
morphos = [],
treebanks = [],
probss = [],
gloptions = noOptions,
readFiles = [],
absCats = [],
statistics = [],
transfers = [],
evalEnv = emptyEEnv
}
optInitShellState :: Options -> ShellState
optInitShellState os = addGlobalOptions os emptyShellState
type Language = Ident
language :: String -> Language
language = identC
prLanguage :: Language -> String
prLanguage = prIdent
-- | grammar for one language in a state, comprising its abs and cnc
data StateGrammar = StGr {
absId :: Ident,
cncId :: Ident,
grammar :: CanonGrammar,
cf :: CF,
mcfg :: Cnv.MGrammar,
fcfg :: FGrammar,
cfg :: Cnv.CGrammar,
pInfo :: Prs.PInfo,
morpho :: Morpho,
probs :: Probs,
loptions :: Options
}
emptyStateGrammar :: StateGrammar
emptyStateGrammar = StGr {
absId = identC "#EMPTY", ---
cncId = identC "#EMPTY", ---
grammar = M.emptyMGrammar,
cf = emptyCF,
mcfg = [],
fcfg = ([], Map.empty),
cfg = [],
pInfo = Prs.buildPInfo [] ([], Map.empty) [],
morpho = emptyMorpho,
probs = emptyProbs,
loptions = noOptions
}
-- analysing shell grammar into parts
stateGrammarST :: StateGrammar -> CanonGrammar
stateCF :: StateGrammar -> CF
stateMCFG :: StateGrammar -> Cnv.MGrammar
stateFCFG :: StateGrammar -> FGrammar
stateCFG :: StateGrammar -> Cnv.CGrammar
statePInfo :: StateGrammar -> Prs.PInfo
stateMorpho :: StateGrammar -> Morpho
stateProbs :: StateGrammar -> Probs
stateOptions :: StateGrammar -> Options
stateGrammarWords :: StateGrammar -> [String]
stateGrammarLang :: StateGrammar -> (CanonGrammar, Ident)
stateGrammarST = grammar
stateCF = cf
stateMCFG = mcfg
stateFCFG = fcfg
stateCFG = cfg
statePInfo = pInfo
stateMorpho = morpho
stateProbs = probs
stateOptions = loptions
stateGrammarWords = allMorphoWords . stateMorpho
stateGrammarLang st = (grammar st, cncId st)
---- this should be computed at compile time and stored
stateHasHOAS :: StateGrammar -> Bool
stateHasHOAS = hasHOAS . stateGrammarST
cncModuleIdST :: StateGrammar -> CanonGrammar
cncModuleIdST = stateGrammarST
-- | form a shell state from a canonical grammar
grammar2shellState :: Options -> (CanonGrammar, G.SourceGrammar) -> Err ShellState
grammar2shellState opts (gr,sgr) =
updateShellState opts doParseAll Nothing emptyShellState ((0,sgr,gr,emptyEEnv),[]) --- is 0 safe?
-- | update a shell state from a canonical grammar
updateShellState :: Options -> NoParse -> Maybe Ident -> ShellState ->
((Int,G.SourceGrammar,CanonGrammar,EEnv),[(String,(FilePath,ModTime))]) ->
Err ShellState
updateShellState opts ign mcnc sh ((_,sgr,gr,eenv),rts) = do
let cgr0 = M.updateMGrammar (canModules sh) gr
-- a0 = abstract of old state
-- a1 = abstract of compiled grammar
let a0 = abstract sh
a1 <- return $ case mcnc of
Just cnc -> err (const Nothing) Just $ M.abstractOfConcrete cgr0 cnc
_ -> M.greatestAbstract cgr0
-- abstr0 = a1 if it exists
let (abstr0,isNew) = case (a0,a1) of
(Just a, Just b) | a /= b -> (a1, True)
(Nothing, Just _) -> (a1, True)
_ -> (a0, False)
let concrs0 = maybe [] (M.allConcretes cgr0) abstr0
let abstrs = nubBy (\ (x,_) (y,_) -> x == y) $
maybe id (\a -> ((a,concrs0):)) abstr0 $ abstracts sh
let needed = nub $ concatMap (requiredCanModules (length abstrs == 1) cgr0) (maybe [] singleton abstr0 ++ concrs0)
purge = nubBy (\x y -> fst x == fst y) . filter (\(m,mo) -> elem m needed && not (isIncompleteCanon (m,mo)))
let cgr = M.MGrammar $ purge $ M.modules cgr0
let oldConcrs = map (snd . fst) (concretes sh)
newConcrs = maybe [] (M.allConcretes gr) abstr0
toRetain (c,v) = notElem c newConcrs
let complete m = case M.lookupModule gr m of
Ok mo -> not $ isIncompleteCanon (m,mo)
_ -> False
let concrs = filter (\i -> complete i && elem i needed) $ nub $ newConcrs ++ oldConcrs
concr0 = ifNull Nothing (return . head) concrs
notInrts f = notElem f $ map fst rts
subcgr = unSubelimCanon cgr
cf's0 <- if (not (oElem (iOpt "docf") opts) && -- cf only built with -docf
(oElem noCF opts || not (hasHOAS cgr))) -- or HOAS, if not -nocf
then return $ map snd $ cfs sh
else mapM (canon2cf opts ign subcgr) newConcrs
let cf's = zip newConcrs cf's0 ++ filter toRetain (cfs sh)
let morphs = [(c,mkMorpho subcgr c) | c <- newConcrs] ++ filter toRetain (morphos sh)
let probss = [] -----
let fromGFC = snd . snd . Cnv.convertGFC opts
(mcfgs, cfgs) = unzip $ map (curry fromGFC cgr) concrs
gfcc = canon2gfcc opts cgr ---- UTF8
fcfgs = [(c,g) | c@(IC cn) <- concrs, Just g <- [lookFCFG gfcc (CId cn)]]
pInfos = zipWith3 Prs.buildPInfo mcfgs (map snd fcfgs) cfgs
let funs = funRulesOf cgr
let cats = allCatsOf cgr
let csi = [(c,(co,
[(fun,typ) | (fun,typ) <- funs, compatType tc typ],
funsOnTypeFs compatType funs tc))
| (c,co) <- cats, let tc = cat2val co c]
let deps = True ---- not $ null $ allDepCats cgr
let binds = [] ---- allCatsWithBind cgr
let src = M.updateMGrammar (srcModules sh) sgr
return $ ShSt {
abstract = abstr0,
concrete = concr0,
concretes = zip (zip concrs concrs) (repeat True),
canModules = cgr,
srcModules = src,
cfs = cf's,
abstracts = maybe [] (\a -> [(a,concrs)]) abstr0,
mcfgs = zip concrs mcfgs,
fcfgs = fcfgs,
cfgs = zip concrs cfgs,
pInfos = zip concrs pInfos,
morphos = morphs,
treebanks = treebanks sh,
probss = zip concrs probss,
gloptions = gloptions sh, --- opts, -- this would be command-line options
readFiles = [ft | ft@(f,(_,_)) <- readFiles sh, notInrts f] ++ rts,
absCats = csi,
statistics = [StDepTypes deps,StBoundVars binds],
transfers = transfers sh,
evalEnv = eenv
}
prShellStateInfo :: ShellState -> String
prShellStateInfo sh = unlines [
"main abstract : " +++ abstractName sh,
"main concrete : " +++ maybe "(none)" P.prt (concrete sh),
"actual concretes : " +++ unwords (map (P.prt . fst . fst) (actualConcretes sh)),
"all abstracts : " +++ unwords (map (P.prt . fst) (abstracts sh)),
"all concretes : " +++ unwords (map (P.prt . fst . fst) (concretes sh)),
"canonical modules :" +++ unwords (map (P.prt .fst) (M.modules (canModules sh))),
"source modules : " +++ unwords (map (P.prt .fst) (M.modules (srcModules sh))),
"global options : " +++ prOpts (gloptions sh),
"transfer modules : " +++ unwords (map (P.prt . fst) (transfers sh)),
"treebanks : " +++ unwords (map (P.prt . fst) (treebanks sh))
]
abstractName :: ShellState -> String
abstractName sh = maybe "(none)" P.prt (abstract sh)
-- | throw away those abstracts that are not needed --- could be more aggressive
filterAbstracts :: [Ident] -> CanonGrammar -> CanonGrammar
filterAbstracts absts cgr = M.MGrammar (nubBy (\x y -> fst x == fst y) [m | m <- ms, needed m]) where
ms = M.modules cgr
needed (i,_) = elem i needs
needs = [i | (i,M.ModMod m) <- ms, not (M.isModAbs m) || any (dep i) absts]
dep i a = elem i (ext mse a)
mse = [(i,me) | (i,M.ModMod m) <- ms, M.isModAbs m, me <- [M.extends m]]
ext es a = case lookup a es of
Just e -> a : concatMap (ext es) e ---- FIX multiple exts
_ -> []
purgeShellState :: ShellState -> ShellState
purgeShellState sh = ShSt {
abstract = abstr,
concrete = concrete sh,
concretes = concrs,
canModules = M.MGrammar $ filter complete $ purge $ M.modules $ canModules sh,
srcModules = M.emptyMGrammar,
cfs = cfs sh,
abstracts = maybe [] (\a -> [(a,map (snd . fst) concrs)]) abstr,
mcfgs = mcfgs sh,
fcfgs = fcfgs sh,
cfgs = cfgs sh,
pInfos = pInfos sh,
morphos = morphos sh,
treebanks = treebanks sh,
probss = probss sh,
gloptions = gloptions sh,
readFiles = [],
absCats = absCats sh,
statistics = statistics sh,
transfers = transfers sh,
evalEnv = emptyEEnv
}
where
abstr = abstract sh
concrs = [((a,i),b) | ((a,i),b) <- concretes sh, elem i needed]
isSingle = length (abstracts sh) == 1
needed = nub $ concatMap (requiredCanModules isSingle (canModules sh)) acncs
purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst)
acncs = maybe [] singleton abstr ++ map (snd . fst) (actualConcretes sh)
complete = not . isIncompleteCanon
changeMain :: Maybe Ident -> ShellState -> Err ShellState
changeMain Nothing (ShSt _ _ cs ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs ee) =
return (ShSt Nothing Nothing [] ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs ee)
changeMain
(Just c) st@(ShSt _ _ cs ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs ee) =
case lookup c (M.modules ms) of
Just _ -> do
a <- M.abstractOfConcrete ms c
let cas = M.allConcretes ms a
let cs' = [((c,c),True) | c <- cas]
return (ShSt (Just a) (Just c) cs' ms ss cfs old_pis mcfgs fcfgs cfgs
pinfos mos tbs pbs os rs acs s trs ee)
_ -> P.prtBad "The state has no concrete syntax named" c
-- | form just one state grammar, if unique, from a canonical grammar
grammar2stateGrammar :: Options -> CanonGrammar -> Err StateGrammar
grammar2stateGrammar opts gr = do
st <- grammar2shellState opts (gr,M.emptyMGrammar)
concr <- maybeErr "no concrete syntax" $ concrete st
return $ stateGrammarOfLang st concr
resourceOfShellState :: ShellState -> Maybe Ident
resourceOfShellState = M.greatestResource . srcModules
qualifTop :: StateGrammar -> G.QIdent -> G.QIdent
qualifTop gr (_,c) = (absId gr,c)
stateGrammarOfLang :: ShellState -> Language -> StateGrammar
stateGrammarOfLang = stateGrammarOfLangOpt True
stateGrammarOfLangOpt :: Bool -> ShellState -> Language -> StateGrammar
stateGrammarOfLangOpt purg st0 l = StGr {
absId = err (const (identC "Abs")) id $ M.abstractOfConcrete allCan l, ---
cncId = l,
grammar = allCan,
cf = maybe emptyCF id (lookup l (cfs st)),
mcfg = maybe [] id $ lookup l $ mcfgs st,
fcfg = maybe ([],Map.empty) id $ lookup l $ fcfgs st,
cfg = maybe [] id $ lookup l $ cfgs st,
pInfo = maybe (Prs.buildPInfo [] ([],Map.empty) []) id $ lookup l $ pInfos st,
morpho = maybe emptyMorpho id (lookup l (morphos st)),
probs = maybe emptyProbs id (lookup l (probss st)),
loptions = errVal noOptions $ lookupOptionsCan allCan
}
where
st = (if purg then purgeShellState else id) $ errVal st0 $ changeMain (Just l) st0
allCan = canModules st
grammarOfLang :: ShellState -> Language -> CanonGrammar
cfOfLang :: ShellState -> Language -> CF
morphoOfLang :: ShellState -> Language -> Morpho
probsOfLang :: ShellState -> Language -> Probs
optionsOfLang :: ShellState -> Language -> Options
grammarOfLang st = stateGrammarST . stateGrammarOfLang st
cfOfLang st = stateCF . stateGrammarOfLang st
morphoOfLang st = stateMorpho . stateGrammarOfLang st
probsOfLang st = stateProbs . stateGrammarOfLang st
optionsOfLang st = stateOptions . stateGrammarOfLang st
removeLang :: Language -> ShellState -> ShellState
removeLang lang st = purgeShellState $ st{concretes = concs1} where
concs1 = filter ((/=lang) . snd . fst) $ concretes st
-- | the last introduced grammar, stored in options, is the default for operations
firstStateGrammar :: ShellState -> StateGrammar
firstStateGrammar st = errVal (stateAbstractGrammar st) $ do
concr <- maybeErr "no concrete syntax" $ concrete st
return $ stateGrammarOfLang st concr
mkStateGrammar :: ShellState -> Language -> StateGrammar
mkStateGrammar = stateGrammarOfLang
stateAbstractGrammar :: ShellState -> StateGrammar
stateAbstractGrammar st = StGr {
absId = maybe (identC "Abs") id (abstract st), ---
cncId = identC "#Cnc", ---
grammar = canModules st, ---- only abstarct ones
cf = emptyCF,
mcfg = [],
fcfg = ([],Map.empty),
cfg = [],
pInfo = Prs.buildPInfo [] ([],Map.empty) [],
morpho = emptyMorpho,
probs = emptyProbs,
loptions = gloptions st ----
}
-- analysing shell state into parts
globalOptions :: ShellState -> Options
allLanguages :: ShellState -> [Language]
allTransfers :: ShellState -> [Ident]
allCategories :: ShellState -> [G.Cat]
allStateGrammars :: ShellState -> [StateGrammar]
allStateGrammarsWithNames :: ShellState -> [(Language, StateGrammar)]
allGrammarFileNames :: ShellState -> [String]
allActiveStateGrammarsWithNames :: ShellState -> [(Language, StateGrammar)]
allActiveGrammars :: ShellState -> [StateGrammar]
globalOptions = gloptions
--allLanguages = map (fst . fst) . concretes
allLanguages = map (snd . fst) . actualConcretes
allTransfers = map fst . transfers
allCategories = map fst . allCatsOf . canModules
allStateGrammars = map snd . allStateGrammarsWithNames
allStateGrammarsWithNames st =
[(c, mkStateGrammar st c) | ((c,_),_) <- actualConcretes st]
allGrammarFileNames st = [prLanguage c ++ ".gf" | ((c,_),_) <- actualConcretes st]
allActiveStateGrammarsWithNames st =
[(c, mkStateGrammar st c) | ((c,_),True) <- concretes st] --- actual
allActiveGrammars = map snd . allActiveStateGrammarsWithNames
pathOfModule :: ShellState -> Ident -> FilePath
pathOfModule sh m = maybe "module not found" fst $ lookup (P.prt m) $ readFiles sh
-- command-line option -lang=foo overrides the actual grammar in state
grammarOfOptState :: Options -> ShellState -> StateGrammar
grammarOfOptState opts st =
maybe (firstStateGrammar st) (stateGrammarOfLang st . language) $
getOptVal opts useLanguage
languageOfOptState :: Options -> ShellState -> Maybe Language
languageOfOptState opts st =
maybe (concrete st) (return . language) $ getOptVal opts useLanguage
-- | command-line option -cat=foo overrides the possible start cat of a grammar
firstCatOpts :: Options -> StateGrammar -> CFCat
firstCatOpts opts sgr =
maybe (stateFirstCat sgr) (string2CFCat (P.prt (absId sgr))) $
getOptVal opts firstCat
-- | the first cat for random generation
firstAbsCat :: Options -> StateGrammar -> G.QIdent
firstAbsCat opts = cfCat2Cat . firstCatOpts opts
-- | Gets the start category for the grammar from the options.
-- If the startcat is not set in the options, we look
-- for a flag in the grammar. If there is no flag in the
-- grammar, S is returned.
startCatStateOpts :: Options -> StateGrammar -> CFCat
startCatStateOpts opts sgr =
string2CFCat a (fromMaybe "S" (optsStartCat `mplus` grStartCat))
where optsStartCat = getOptVal opts gStartCat
grStartCat = getOptVal (stateOptions sgr) gStartCat
a = P.prt (absId sgr)
-- | a grammar can have start category as option startcat=foo ; default is S
stateFirstCat :: StateGrammar -> CFCat
stateFirstCat = startCatStateOpts noOptions
stateIsWord :: StateGrammar -> String -> Bool
stateIsWord sg = isKnownWord (stateMorpho sg)
addProbs :: (Ident,Probs) -> ShellState -> Err ShellState
addProbs ip@(lang,probs) sh = do
let gr = grammarOfLang sh lang
probs' <- checkGrammarProbs gr probs
let pbs' = (lang,probs') : filter ((/= lang) . fst) (probss sh)
return $ sh{probss = pbs'}
addTransfer :: (Ident,T.Env) -> ShellState -> ShellState
addTransfer it@(i,_) sh =
sh {transfers = it : filter ((/= i) . fst) (transfers sh)}
addTreebanks :: [(Ident,Treebank)] -> ShellState -> ShellState
addTreebanks its sh = sh {treebanks = its ++ treebanks sh}
findTreebank :: ShellState -> Ident -> Err Treebank
findTreebank sh i = maybeErr "no treebank found" $ lookup i $ treebanks sh
-- modify state
type ShellStateOper = ShellState -> ShellState
type ShellStateOperErr = ShellState -> Err ShellState
reinitShellState :: ShellStateOper
reinitShellState = const emptyShellState
languageOn, languageOff :: Language -> ShellStateOper
languageOn = languageOnOff True
languageOff = languageOnOff False
languageOnOff :: Bool -> Language -> ShellStateOper
--- __________ this is OBSOLETE
languageOnOff b lang sh = sh {concretes = cs'} where
cs' = [if lang==l then (lc,b) else i | i@(lc@(l,c),_) <- concretes sh]
changeOptions :: (Options -> Options) -> ShellStateOper
--- __________ this is OBSOLETE
changeOptions f sh = sh {gloptions = f (gloptions sh)}
addGlobalOptions :: Options -> ShellStateOper
addGlobalOptions = changeOptions . addOptions
removeGlobalOptions :: Options -> ShellStateOper
removeGlobalOptions = changeOptions . removeOptions

108
src-3.0/GF/Compile/Wordlist.hs
View File

@@ -1,108 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : Wordlist
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date:
-- > CVS $Author:
-- > CVS $Revision:
--
-- Compile a gfwl file (multilingual word list) to an abstract + concretes
-----------------------------------------------------------------------------
module GF.Compile.Wordlist (mkWordlist) where
import GF.Data.Operations
import GF.Infra.UseIO
import Data.List
import Data.Char
import System.FilePath
-- read File.gfwl, write File.gf (abstract) and a set of concretes
-- return the names of the concretes
mkWordlist :: FilePath -> IO [FilePath]
mkWordlist file = do
s <- readFileIf file
let abs = dropExtension file
let (cnchs,wlist) = pWordlist abs $ filter notComment $ lines s
let (gr,grs) = mkGrammars abs cnchs wlist
let cncfs = [cnc ++ ".gf" | (cnc,_) <- cnchs]
mapM_ (uncurry writeFile) $ (abs ++ ".gf",gr) : zip cncfs grs
putStrLn $ "wrote " ++ unwords ((abs ++ ".gf") : cncfs)
return cncfs
{-
-- syntax of files, e.g.
# Svenska - Franska - Finska -- names of concretes
berg - montagne - vuori -- word entry
-- this creates:
cat S ;
fun berg_S : S ;
lin berg_S = {s = ["berg"]} ;
lin berg_S = {s = ["montagne"]} ;
lin berg_S = {s = ["vuori"]} ;
-- support for different categories to be elaborated. The syntax it
Verb . klättra - grimper / escalader - kiivetä / kiipeillä
-- notice that a word can have several alternative (separator /)
-- and that an alternative can consist of several words
-}
type CncHeader = (String,String) -- module name, module header
type Wordlist = [(String, [[String]])] -- cat, variants for each cnc
pWordlist :: String -> [String] -> ([CncHeader],Wordlist)
pWordlist abs ls = (headers,rules) where
(hs,rs) = span ((=="#") . take 1) ls
headers = map mkHeader $ chunks "-" $ filter (/="#") $ words $ concat hs
rules = map (mkRule . words) rs
mkHeader ws = case ws of
w:ws2 -> (w, unwords ("concrete":w:"of":abs:"=":ws2))
mkRule ws = case ws of
cat:".":vs -> (cat, mkWords vs)
_ -> ("S", mkWords ws)
mkWords = map (map unwords . chunks "/") . chunks "-"
mkGrammars :: String -> [CncHeader] -> Wordlist -> (String,[String])
mkGrammars ab hs wl = (abs,cncs) where
abs = unlines $ map unwords $
["abstract",ab,"=","{"]:
cats ++
funs ++
[["}"]]
cncs = [unlines $ (h ++ " {") : map lin rs ++ ["}"] | ((_,h),rs) <- zip hs rss]
cats = [["cat",c,";"] | c <- nub $ map fst wl]
funs = [["fun", f , ":", c,";"] | (f,c,_) <- wlf]
wlf = [(ident f c, c, ws) | (c,ws@(f:_)) <- wl]
rss = [[(f, wss !! i) | (f,_,wss) <- wlf] | i <- [0..length hs - 1]]
lin (f,ss) = unwords ["lin", f, "=", "{s", "=", val ss, "}", ";"]
val ss = case ss of
[w] -> quote w
_ -> "variants {" ++ unwords (intersperse ";" (map quote ss)) ++ "}"
quote w = "[" ++ prQuotedString w ++ "]"
ident f c = concat $ intersperse "_" $ words (head f) ++ [c]
notComment s = not (all isSpace s) && take 2 s /= "--"