GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

-val optimization

Browse Source
This commit is contained in:
aarne
2005-01-11 15:06:12 +00:00
parent 496416d7ab
commit a19856618b
36 changed files with 829 additions and 585 deletions
Download Patch File Download Diff File Expand all files Collapse all files

183
doc/val-optimization.txt Normal file
View File

@@ -0,0 +1,183 @@
Idea: in GFC, represent tables as just lists values, without showing
the parameters.
Concrete syntax:
table T [t1 ; ... ; tn]
where t1,...,tn are terms. This is treated as equivalent to
table {p1 => t1 ; ... ; pn => tn}
where p1,...,pn is the canonical listing of patterns of type T.
Advantage: reduce the size of GFC files.
Disadvantages: you don't get the sharing optimization, e.g.
table {A|B => v} instead of table T [v ; v]
Moreover, it is slower to select from the table, because
one first has to look up the position index of the argument.
Usage: when compiling a module, use the -val option:
i -val -src Foo.gf
Summary of results, testing with lib/resource/french/TestVerbesFre.gf:
without -val with -val ratio
compilation time 129 s 84 s 65 %
time to read back gfcm 109 s 32 s 29 %
size of generated gfcm 28 M 9 M 32 %
memory use in compilation 376 M 251 M 67 %
memory use in reading gfcm 1120 M 524 M 47 %
No significant loss in linearization (which needs selection).
Conclusion: for the case at hand (which prompted the experiment
at the first place), the gain is significant: compilation needs
30 % less resources, and using the compiled grammar needs
50-70 % less.
More testing is desirable to find out if -val is always good.
At the moment, reuse is not possible with gfc modules created
with the -val flag (although it is supported by the GF syntax
already).
10/1/2004
Test the generation of course-of-values tables
---------------------
Without:
i -src TestVerbesFre.gf
129160 msec
> gr -cat=V | l -table
650 msec
gf +RTS -K10M -s
8,469,778,952 bytes allocated in the heap
2,779,891,252 bytes copied during GC
133,108,856 bytes maximum residency (36 sample(s))
32295 collections in generation 0 ( 24,25s)
36 collections in generation 1 ( 24,68s)
376 Mb total memory in use
INIT time 0,01s ( 0,04s elapsed)
MUT time 80,21s (499,76s elapsed)
GC time 48,93s ( 50,01s elapsed)
EXIT time 0,00s ( 0,00s elapsed)
Total time 129,15s (549,81s elapsed)
%GC time 37,9% (9,1% elapsed)
Alloc rate 105,581,886 bytes per MUT second
Productivity 62,1% of total user, 14,6% of total elapsed
wc french/*.gfc french/*.gfr
37 2533 44976 french/CategoriesFre.gfc
0 9 62 french/ConjugNancy.gfc
2 29 137 french/MorphoFre.gfc
29 966 7641 french/NumeralsFre.gfc
136 393891 4415193 french/RulesFre.gfc
151 4211 39290 french/StructuralFre.gfc
123 607 3259 french/SyntaxFre.gfc
285 4702 59892 french/TestResourceFre.gfc
6790 27179 184046 french/TestVerbesAbs.gfc
6781 28170 198376 french/TestVerbesFre.gfc
20 214 1245 french/TypesFre.gfc
6494 45458 254878 french/VerbesAbs.gfc
6494 1272600 23438292 french/VerbesFre.gfc
6449 45143 209154 french/Vs.gfc
6278 47836 426316 french/ConjugNancy.gfr
14465 72471 655006 french/MorphoFre.gfr
238250 798560 8973600 french/SyntaxFre.gfr
492 2557 21908 french/TypesFre.gfr
293276 2747136 38933271 total
pm | wf test0.gfcm
55660 msec
wc test0.gfcm
28041 1784674 28669416 test0.gfcm
> i test0.gfcm
+ reading test0.gfcm 103290 msec
109450 msec
1120 Mb total memory in use
----------------------
After:
i -src -val TestVerbesFre.gf
84650 msec
gr -cat=V | l -table
390 msec
gf +RTS -K10M -s
6,061,907,436 bytes allocated in the heap
1,576,739,488 bytes copied during GC
92,700,188 bytes maximum residency (32 sample(s))
23109 collections in generation 0 ( 13,98s)
32 collections in generation 1 ( 12,02s)
251 Mb total memory in use
INIT time 0,01s ( 0,00s elapsed)
MUT time 59,28s (122,35s elapsed)
GC time 26,00s ( 26,91s elapsed)
EXIT time 0,00s ( 0,00s elapsed)
Total time 85,29s (149,26s elapsed)
%GC time 30,5% (18,0% elapsed)
Alloc rate 102,241,650 bytes per MUT second
Productivity 69,5% of total user, 39,7% of total elapsed
wc french/*.gfc french/*.gfr
37 3894 13600 french/CategoriesFre.gfc
0 9 62 french/ConjugNancy.gfc
2 29 137 french/MorphoFre.gfc
29 938 5726 french/NumeralsFre.gfc
136 354450 3097901 french/RulesFre.gfc
151 3738 22354 french/StructuralFre.gfc
123 607 3259 french/SyntaxFre.gfc
285 2437 18664 french/TestResourceFre.gfc
6790 27179 184046 french/TestVerbesAbs.gfc
6781 27694 191696 french/TestVerbesFre.gfc
20 214 1245 french/TypesFre.gfc
6494 45458 254878 french/VerbesAbs.gfc
6494 442149 5078881 french/VerbesFre.gfc
6449 45143 209154 french/Vs.gfc
6278 47836 426316 french/ConjugNancy.gfr
14465 72471 655006 french/MorphoFre.gfr
238250 798560 8973600 french/SyntaxFre.gfr
492 2557 21908 french/TypesFre.gfr
293276 1875363 19158433 total
pm | wf test1.gfcm
13030 msec
wc test1.gfcm
28041 912901 8894578 test1.gfcm
> i test1.gfcm
+ reading test1.gfcm 24220 msec
32720 msec
524 Mb total memory in use

2
grammars/database/DatabaseI.gf
View File

@@ -1,6 +1,6 @@
--# -path=.:../newresource/abstract:../prelude
incomplete concrete DatabaseI of Database = open Prelude, Resource, Structural in {
incomplete concrete DatabaseI of Database = open Prelude, Resource in {
flags lexer=text ; unlexer=text ;

2
lib/resource/italian/StructuralIta.gf
View File

@@ -69,7 +69,7 @@ lin
OtherwiseAdv = ss "altramente" ;
ThereforeAdv = ss "quindi" ;
EverybodyNP = mkNameNounPhrase ["tutti"] Masc ;
EverybodyNP = normalNounPhrase (\\c => prepCase c ++ "tutti") Masc Pl ;
SomebodyNP = mkNameNounPhrase ["qualcuno"] Masc ;
NobodyNP = mkNameNounPhrase ["nessuno"] Masc ; --- ne
EverythingNP = mkNameNounPhrase ["tutto"] Masc ;

2
lib/resource/spanish/StructuralSpa.gf
View File

@@ -71,7 +71,7 @@ lin
OtherwiseAdv = ss "otramente" ;
ThereforeAdv = ss ["por eso"] ;
EverybodyNP = mkNameNounPhrase ["todos"] Masc ;
EverybodyNP = normalNounPhrase (\\c => prepCase c ++ "todos") Masc Pl ;
SomebodyNP = mkNameNounPhrase ["algún"] Masc ;
NobodyNP = mkNameNounPhrase ["nadién"] Masc ; --- ne
EverythingNP = mkNameNounPhrase ["todo"] Masc ;

2
lib/resource/spanish/TestResourceSpa.gf
View File

@@ -36,7 +36,7 @@ lin
SwitchOn = mkTransVerbDir (verbPres (vender_4 "enciender") AHabere) ; ----
SwitchOff = mkTransVerbDir (verbPres (zurrar_3 "apagar") AHabere) ;
Mother = funGen (mkCNom (nomVino "madre") Fem) ;
Uncle = funGen (mkCNom (nomVino "zio") Masc) ;
Uncle = funGen (mkCNom (nomVino "tío") Masc) ;
Connection = mkCNom (nomPilar "connexión") Fem **
{s2 = [] ; c = CPrep P_de ; s3 = [] ; c3 = dative} ;

2
lib/resource/spanish/TypesSpa.gf
View File

@@ -117,7 +117,7 @@ oper
VFin VFut n p => amare.s ! VP (Fut Ind n p) ;
VFin VCondit n p => amare.s ! VP (Cond n p) ;
VImper np => amare.s ! VP (Imp Sg P2) ; ---- n p ;
VPart g n => amare.s ! VI Part ---- g n ?
VPart g n => amare.s ! VP (Pass n g)
} ;
aux = a
} ;

3
src/GF/CF/CanonToCF.hs
View File

@@ -97,6 +97,9 @@ term2CFItems m t = errIn "forming cf items" $ case t of
T _ cc -> do
its <- mapM t2c [t | Cas _ t <- cc]
tryMkCFTerm (concat its)
V _ cc -> do
its <- mapM t2c [t | t <- cc]
tryMkCFTerm (concat its)
C t1 t2 -> do
its1 <- t2c t1

1
src/GF/Canon/AbsGFC.hs
View File

@@ -119,6 +119,7 @@ data Term =
| R [Assign]
| P Term Label
| T CType [Case]
| V CType [Term]
| S Term Term
| C Term Term
| FV [Term]

4
src/GF/Canon/CanonToGrammar.hs
View File

@@ -136,6 +136,10 @@ redCTerm x = case x of
[G.PV _] -> G.TTyped ctype'
_ -> G.TComp ctype'
return $ G.T tinfo $ zip ps' ts'
V ctype ts -> do
ctype' <- redCType ctype
ts' <- mapM redCTerm ts
return $ G.V ctype' ts'
S term0 term -> liftM2 G.S (redCTerm term0) (redCTerm term)
C term0 term -> liftM2 G.C (redCTerm term0) (redCTerm term)
FV terms -> liftM G.FV $ mapM redCTerm terms

1
src/GF/Canon/GFC.cf
View File

@@ -105,6 +105,7 @@ LI. Term2 ::= "$" Ident ; -- from pattern variables
R. Term2 ::= "{" [Assign] "}" ;
P. Term1 ::= Term2 "." Label ;
T. Term1 ::= "table" CType "{" [Case] "}" ;
V. Term1 ::= "table" CType "[" [Term2] "]" ;
S. Term1 ::= Term1 "!" Term2 ;
C. Term ::= Term "++" Term1 ;
FV. Term1 ::= "variants" "{" [Term2] "}" ; --- no separator!

148
src/GF/Canon/LexGFC.hs
View File

File diff suppressed because one or more lines are too long

46
src/GF/Canon/LexGFC.x
View File

@@ -4,7 +4,6 @@
module LexGFC where
import ErrM
import SharedString
}
@@ -21,28 +20,25 @@ $u = [\0-\255] -- universal: any character
:-
$white+ ;
@rsyms { tok (\p s -> PT p (TS $ share s)) }
@rsyms { tok (\p s -> PT p (TS s)) }
$l $i* { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) }
$l $i* { tok (\p s -> PT p (eitherResIdent TV s)) }
\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ unescapeInitTail s)) }
$d+ { tok (\p s -> PT p (TI $ share s)) }
$d+ { tok (\p s -> PT p (TI s)) }
{
tok f p s = f p s
share :: String -> String
share = shareString
data Tok =
TS !String -- reserved words
| TL !String -- string literals
| TI !String -- integer literals
| TV !String -- identifiers
| TD !String -- double precision float literals
| TC !String -- character literals
TS String -- reserved words
| TL String -- string literals
| TI String -- integer literals
| TV String -- identifiers
| TD String -- double precision float literals
| TC String -- character literals
deriving (Eq,Show,Ord)
@@ -67,18 +63,20 @@ prToken t = case t of
_ -> show t
data BTree = N | B String Tok BTree BTree deriving (Show)
eitherResIdent :: (String -> Tok) -> String -> Tok
eitherResIdent tv s = treeFind resWords
where
treeFind N = tv s
treeFind (B a t left right) | s < a = treeFind left
| s > a = treeFind right
| s == a = t
eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where
isResWord s = isInTree s $
B "lin" (B "concrete" (B "Type" (B "Str" (B "Ints" N N) N) (B "cat" (B "abstract" N N) N)) (B "fun" (B "flags" (B "data" N N) N) (B "in" (B "grammar" N N) N))) (B "pre" (B "open" (B "of" (B "lincat" N N) N) (B "param" (B "oper" N N) N)) (B "transfer" (B "table" (B "resource" N N) N) (B "variants" N N)))
resWords = b "lin" (b "concrete" (b "Type" (b "Str" (b "Ints" N N) N) (b "cat" (b "abstract" N N) N)) (b "fun" (b "flags" (b "data" N N) N) (b "in" (b "grammar" N N) N))) (b "pre" (b "open" (b "of" (b "lincat" N N) N) (b "param" (b "oper" N N) N)) (b "transfer" (b "table" (b "resource" N N) N) (b "variants" N N)))
where b s = B s (TS s)
data BTree = N | B String BTree BTree deriving (Show)
isInTree :: String -> BTree -> Bool
isInTree x tree = case tree of
N -> False
B a left right
| x < a -> isInTree x left
| x > a -> isInTree x right
| x == a -> True
unescapeInitTail :: String -> String
unescapeInitTail = unesc . tail where

6
src/GF/Canon/Look.hs
View File

@@ -151,6 +151,12 @@ ccompute cnc = comp []
T ty rs -> liftM (T ty . map (uncurry Cas)) $
mapPairsM compt [(l,r) | Cas l r <- rs]
V ptyp ts -> do
vs0 <- allParamValues cnc ptyp
vs <- mapM term2patt vs0
let cc = [Cas [p] u | (p,u) <- zip vs ts]
compt $ T ptyp cc
Con c xs -> liftM (Con c) $ mapM compt xs
K (KS []) -> return E --- should not be needed

264
src/GF/Canon/ParGFC.hs
View File

File diff suppressed because one or more lines are too long

1
src/GF/Canon/PrintGFC.hs
View File

@@ -258,6 +258,7 @@ instance Print Term where
R assigns -> prPrec i 2 (concatD [doc (showString "{") , prt 0 assigns , doc (showString "}")])
P term label -> prPrec i 1 (concatD [prt 2 term , doc (showString ".") , prt 0 label])
T ctype cases -> prPrec i 1 (concatD [doc (showString "table") , prt 0 ctype , doc (showString "{") , prt 0 cases , doc (showString "}")])
V ctype terms -> prPrec i 1 (concatD [doc (showString "table") , prt 0 ctype , doc (showString "[") , prt 2 terms , doc (showString "]")])
S term0 term -> prPrec i 1 (concatD [prt 1 term0 , doc (showString "!") , prt 2 term])
C term0 term -> prPrec i 0 (concatD [prt 0 term0 , doc (showString "++") , prt 1 term])
FV terms -> prPrec i 1 (concatD [doc (showString "variants") , doc (showString "{") , prt 2 terms , doc (showString "}")])

9
src/GF/Canon/Share.hs
View File

@@ -1,4 +1,4 @@
module Share (shareModule, OptSpec, basicOpt, fullOpt) where
module Share (shareModule, OptSpec, basicOpt, fullOpt, valOpt) where
import AbsGFC
import Ident
@@ -13,8 +13,10 @@ import qualified Modules as M
type OptSpec = [Integer] ---
doOptFactor opt = elem 2 opt
doOptValues opt = elem 3 opt
basicOpt = []
fullOpt = [2]
valOpt = [3]
shareModule :: OptSpec -> (Ident, CanonModInfo) -> (Ident, CanonModInfo)
shareModule opt (i,m) = case m of
@@ -30,6 +32,7 @@ shareInfo _ i = i
shareOpt :: OptSpec -> Term -> Term
shareOpt opt
| doOptFactor opt = share . factor 0
| doOptValues opt = values
| otherwise = share
-- we need no counter to create new variable names, since variables are
@@ -114,3 +117,7 @@ replace old new trm = case trm of
R _ -> True
_ -> False
values :: Term -> Term
values t = case t of
T ty cs -> V ty [values t | Cas _ t <- cs] -- assumes proper order
_ -> C.composSafeOp values t

2
src/GF/Canon/SkelGFC.hs
View File

@@ -146,6 +146,7 @@ transTerm x = case x of
R assigns -> failure x
P term label -> failure x
T ctype cases -> failure x
V ctype terms -> failure x
S term0 term -> failure x
C term0 term -> failure x
FV terms -> failure x
@@ -158,6 +159,7 @@ transTokn :: Tokn -> Result
transTokn x = case x of
KS str -> failure x
KP strs variants -> failure x
KM str -> failure x
transAssign :: Assign -> Result

28
src/GF/Canon/TestGFC.hs
View File

@@ -18,22 +18,28 @@ type ParseFun a = [Token] -> Err a
myLLexer = myLexer
runFile :: (Print a, Show a) => ParseFun a -> FilePath -> IO ()
runFile p f = readFile f >>= run p
type Verbosity = Int
run :: (Print a, Show a) => ParseFun a -> String -> IO ()
run p s = case (p (myLLexer s)) of
Bad s -> do putStrLn "\nParse Failed...\n"
putStrV :: Verbosity -> String -> IO ()
putStrV v s = if v > 1 then putStrLn s else return ()
runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()
runFile v p f = putStrLn f >> readFile f >>= run v p
run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()
run v p s = let ts = myLLexer s in case p ts of
Bad s -> do putStrLn "\nParse Failed...\n"
putStrV v "Tokens:"
putStrV v $ show ts
putStrLn s
Ok tree -> do putStrLn "\nParse Successful!"
putStrLn $ "\n[Abstract Syntax]\n\n" ++ show tree
putStrLn $ "\n[Linearized tree]\n\n" ++ printTree tree
putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree
putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree
main :: IO ()
main = do args <- getArgs
case args of
[] -> hGetContents stdin >>= run pCanon
[f] -> runFile pCanon f
_ -> do progName <- getProgName
putStrLn $ progName ++ ": excess arguments."
[] -> hGetContents stdin >>= run 2 pCanon
"-s":fs -> mapM_ (runFile 0 pCanon) fs
fs -> mapM_ (runFile 2 pCanon) fs

10
src/GF/Compile/Compile.hs
View File

@@ -252,9 +252,12 @@ generateModuleCode :: Options -> InitPath -> SourceModule -> IOE GFC.CanonModule
generateModuleCode opts path minfo@(name,info) = do
let pname = prefixPathName path (prt name)
minfo0 <- ioeErr $ redModInfo minfo
minfo' <- return $ if optim
then shareModule fullOpt minfo0 -- parametrization and sharing
else shareModule basicOpt minfo0 -- sharing only
minfo' <- return $
if optim
then shareModule fullOpt minfo0 -- parametrization and sharing
else if values
then shareModule valOpt minfo0 -- tables as courses-of-values
else shareModule basicOpt minfo0 -- sharing only
-- for resource, also emit gfr
case info of
@@ -279,6 +282,7 @@ generateModuleCode opts path minfo@(name,info) = do
nomulti = not $ oElem makeMulti opts
emit = oElem emitCode opts && not (oElem notEmitCode opts)
optim = oElem optimizeCanon opts
values = oElem optimizeValues opts
-- for old GF: sort into modules, write files, compile as usual

4
src/GF/Compile/GrammarToCanon.hs
View File

@@ -198,6 +198,10 @@ redCTerm t = case t of
ps' <- mapM redPatt ps
ts' <- mapM redCTerm ts
return $ G.T ty' $ map (uncurry G.Cas) $ zip (map singleton ps') 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 $ toInteger i

1
src/GF/Compile/Optimize.hs
View File

@@ -188,6 +188,7 @@ evalPrintname gr c ppr lin =
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

14
src/GF/Grammar/Compute.hs
View File

@@ -101,6 +101,17 @@ computeTerm gr = comp where
FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . FV
V ptyp ts -> do
vs <- allParamValues gr ptyp
ps <- mapM term2patt vs
let cc = zip ps ts
case v' of
FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . FV
_ -> case matchPattern cc v' of
Ok (c,g') -> comp (g' ++ g) c
_ | isCan v' -> prtBad ("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 . FV
_ -> case matchPattern cc v' of
@@ -204,7 +215,8 @@ computeTerm gr = comp where
ts <- mapM (\ (c,g') -> comp (g' ++ g) c) sts
ps <- mapM term2patt vs
let ps' = ps --- PT ptyp (head ps) : tail ps
return $ T (TComp ptyp) (zip ps' ts)
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

1
src/GF/Grammar/Grammar.hs
View File

@@ -77,6 +77,7 @@ data Term =
| Table Term Term -- table type: P => A
| T TInfo [Case] -- table: table {p => c ; ...}
| V Type [Term] -- table given as course of values: table T [c1 ; ... ; cn]
| S Term Term -- selection: t ! p
| Let LocalDef Term -- local definition: let {t : T = a} in b

6
src/GF/Grammar/Macros.hs
View File

@@ -588,6 +588,12 @@ composOp co trm =
do cc' <- mapPairListM (co . snd) cc
i' <- changeTableType co i
return (T i' cc')
V ty vs ->
do ty' <- co ty
vs' <- mapM co vs
return (V ty' vs')
Let (x,(mt,a)) b ->
do a' <- co a
mt' <- case mt of

1
src/GF/Infra/Option.hs
View File

@@ -163,6 +163,7 @@ doTrace = iOpt "tr"
noCPU = iOpt "nocpu"
doCompute = iOpt "c"
optimizeCanon = iOpt "opt"
optimizeValues = iOpt "val"
stripQualif = iOpt "strip"
nostripQualif = iOpt "nostrip"
showAll = iOpt "all"

2
src/GF/Shell/ShellCommands.hs
View File

@@ -134,7 +134,7 @@ testValidFlag st co f x = case f of
optionsOfCommand :: Command -> ([String],[String])
optionsOfCommand co = case co of
CImport _ -> both "old v s opt src retain nocf nocheckcirc cflexer noemit o"
CImport _ -> both "old v s opt val src retain nocf nocheckcirc cflexer noemit o"
"abs cnc res path"
CRemoveLanguage _ -> none
CEmptyState -> none

1
src/GF/Source/AbsGF.hs
View File

@@ -167,6 +167,7 @@ data Exp =
| EQCons Ident Ident
| EApp Exp Exp
| ETable [Case]
| EVTable Exp [Exp]
| ETTable Exp [Case]
| ECase Exp [Case]
| EVariants [Exp]

1
src/GF/Source/GF.cf
View File

@@ -160,6 +160,7 @@ EQCons. Exp3 ::= "[" Ident "." Ident "]" ; -- qualified constant
EApp. Exp2 ::= Exp2 Exp3 ;
ETable. Exp2 ::= "table" "{" [Case] "}" ;
ETTable. Exp2 ::= "table" Exp4 "{" [Case] "}" ;
EVTable. Exp2 ::= "table" Exp4 "[" [Exp] "]" ;
ECase. Exp2 ::= "case" Exp "of" "{" [Case] "}" ;
EVariants. Exp2 ::= "variants" "{" [Exp] "}" ;
EPre. Exp2 ::= "pre" "{" Exp ";" [Altern] "}" ;

1
src/GF/Source/GrammarToSource.hs
View File

@@ -129,6 +129,7 @@ trt trm = case trm of
T (TComp ty) cc -> P.ETTable (trt ty) (map trCase cc)
T (TWild ty) cc -> P.ETTable (trt ty) (map trCase cc)
T _ cc -> P.ETable (map trCase cc)
V ty cc -> P.EVTable (trt ty) (map trt cc)
Table x v -> P.ETType (trt x) (trt v)
S f x -> P.ESelect (trt f) (trt x)

152
src/GF/Source/LexGF.hs
View File

File diff suppressed because one or more lines are too long

50
src/GF/Source/LexGF.x
View File

@@ -4,7 +4,6 @@
module LexGF where
import ErrM
import SharedString
}
@@ -23,30 +22,27 @@ $u = [\0-\255] -- universal: any character
"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ;
$white+ ;
@rsyms { tok (\p s -> PT p (TS $ share s)) }
\' ($u # \')* \' { tok (\p s -> PT p (eitherResIdent (T_LString . share) s)) }
@rsyms { tok (\p s -> PT p (TS s)) }
\' ($u # \')* \' { tok (\p s -> PT p (eitherResIdent T_LString s)) }
$l $i* { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) }
$l $i* { tok (\p s -> PT p (eitherResIdent TV s)) }
\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ unescapeInitTail s)) }
$d+ { tok (\p s -> PT p (TI $ share s)) }
$d+ { tok (\p s -> PT p (TI s)) }
{
tok f p s = f p s
share :: String -> String
share = shareString
data Tok =
TS !String -- reserved words
| TL !String -- string literals
| TI !String -- integer literals
| TV !String -- identifiers
| TD !String -- double precision float literals
| TC !String -- character literals
| T_LString !String
TS String -- reserved words
| TL String -- string literals
| TI String -- integer literals
| TV String -- identifiers
| TD String -- double precision float literals
| TC String -- character literals
| T_LString String
deriving (Eq,Show,Ord)
@@ -72,18 +68,20 @@ prToken t = case t of
_ -> show t
data BTree = N | B String Tok BTree BTree deriving (Show)
eitherResIdent :: (String -> Tok) -> String -> Tok
eitherResIdent tv s = treeFind resWords
where
treeFind N = tv s
treeFind (B a t left right) | s < a = treeFind left
| s > a = treeFind right
| s == a = t
eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where
isResWord s = isInTree s $
B "lincat" (B "def" (B "Type" (B "Str" (B "PType" (B "Lin" N N) N) (B "Tok" (B "Strs" N N) N)) (B "cat" (B "case" (B "abstract" N N) N) (B "data" (B "concrete" N N) N))) (B "include" (B "fun" (B "fn" (B "flags" N N) N) (B "in" (B "grammar" N N) N)) (B "interface" (B "instance" (B "incomplete" N N) N) (B "lin" (B "let" N N) N)))) (B "resource" (B "out" (B "of" (B "lintype" (B "lindef" N N) N) (B "oper" (B "open" N N) N)) (B "pattern" (B "param" (B "package" N N) N) (B "printname" (B "pre" N N) N))) (B "union" (B "table" (B "strs" (B "reuse" N N) N) (B "transfer" (B "tokenizer" N N) N)) (B "where" (B "variants" (B "var" N N) N) (B "with" N N))))
resWords = b "lincat" (b "def" (b "Type" (b "Str" (b "PType" (b "Lin" N N) N) (b "Tok" (b "Strs" N N) N)) (b "cat" (b "case" (b "abstract" N N) N) (b "data" (b "concrete" N N) N))) (b "include" (b "fun" (b "fn" (b "flags" N N) N) (b "in" (b "grammar" N N) N)) (b "interface" (b "instance" (b "incomplete" N N) N) (b "lin" (b "let" N N) N)))) (b "resource" (b "out" (b "of" (b "lintype" (b "lindef" N N) N) (b "oper" (b "open" N N) N)) (b "pattern" (b "param" (b "package" N N) N) (b "printname" (b "pre" N N) N))) (b "union" (b "table" (b "strs" (b "reuse" N N) N) (b "transfer" (b "tokenizer" N N) N)) (b "where" (b "variants" (b "var" N N) N) (b "with" N N))))
where b s = B s (TS s)
data BTree = N | B String BTree BTree deriving (Show)
isInTree :: String -> BTree -> Bool
isInTree x tree = case tree of
N -> False
B a left right
| x < a -> isInTree x left
| x > a -> isInTree x right
| x == a -> True
unescapeInitTail :: String -> String
unescapeInitTail = unesc . tail where

432
src/GF/Source/ParGF.hs
View File

File diff suppressed because one or more lines are too long

1
src/GF/Source/PrintGF.hs
View File

@@ -334,6 +334,7 @@ instance Print Exp where
EApp exp0 exp -> prPrec i 2 (concatD [prt 2 exp0 , prt 3 exp])
ETable cases -> prPrec i 2 (concatD [doc (showString "table") , doc (showString "{") , prt 0 cases , doc (showString "}")])
ETTable exp cases -> prPrec i 2 (concatD [doc (showString "table") , prt 4 exp , doc (showString "{") , prt 0 cases , doc (showString "}")])
EVTable exp exps -> prPrec i 2 (concatD [doc (showString "table") , prt 4 exp , doc (showString "[") , prt 0 exps , doc (showString "]")])
ECase exp cases -> prPrec i 2 (concatD [doc (showString "case") , prt 0 exp , doc (showString "of") , doc (showString "{") , prt 0 cases , doc (showString "}")])
EVariants exps -> prPrec i 2 (concatD [doc (showString "variants") , doc (showString "{") , prt 0 exps , doc (showString "}")])
EPre exp alterns -> prPrec i 2 (concatD [doc (showString "pre") , doc (showString "{") , prt 0 exp , doc (showString ";") , prt 0 alterns , doc (showString "}")])

1
src/GF/Source/SkelGF.hs
View File

@@ -206,6 +206,7 @@ transExp x = case x of
EApp exp0 exp -> failure x
ETable cases -> failure x
ETTable exp cases -> failure x
EVTable exp exps -> failure x
ECase exp cases -> failure x
EVariants exps -> failure x
EPre exp alterns -> failure x

2
src/GF/Source/SourceToGrammar.hs
View File

@@ -350,6 +350,8 @@ transExp x = case x of
ETable cases -> liftM (G.T G.TRaw) (transCases cases)
ETTable exp cases ->
liftM2 (\t c -> G.T (G.TTyped t) c) (transExp exp) (transCases cases)
EVTable exp cases ->
liftM2 (\t c -> G.V t c) (transExp exp) (mapM transExp cases)
ECase exp cases -> do
exp' <- transExp exp
cases' <- transCases cases

28
src/GF/Source/TestGF.hs
View File

@@ -18,22 +18,28 @@ type ParseFun a = [Token] -> Err a
myLLexer = myLexer
runFile :: (Print a, Show a) => ParseFun a -> FilePath -> IO ()
runFile p f = readFile f >>= run p
type Verbosity = Int
run :: (Print a, Show a) => ParseFun a -> String -> IO ()
run p s = case (p (myLLexer s)) of
Bad s -> do putStrLn "\nParse Failed...\n"
putStrV :: Verbosity -> String -> IO ()
putStrV v s = if v > 1 then putStrLn s else return ()
runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()
runFile v p f = putStrLn f >> readFile f >>= run v p
run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()
run v p s = let ts = myLLexer s in case p ts of
Bad s -> do putStrLn "\nParse Failed...\n"
putStrV v "Tokens:"
putStrV v $ show ts
putStrLn s
Ok tree -> do putStrLn "\nParse Successful!"
putStrLn $ "\n[Abstract Syntax]\n\n" ++ show tree
putStrLn $ "\n[Linearized tree]\n\n" ++ printTree tree
putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree
putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree
main :: IO ()
main = do args <- getArgs
case args of
[] -> hGetContents stdin >>= run pGrammar
[f] -> runFile pGrammar f
_ -> do progName <- getProgName
putStrLn $ progName ++ ": excess arguments."
[] -> hGetContents stdin >>= run 2 pGrammar
"-s":fs -> mapM_ (runFile 0 pGrammar) fs
fs -> mapM_ (runFile 2 pGrammar) fs