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

Remove workarounds for bugs in canonical format

Browse Source
This commit is contained in:
John J. Camilleri
2021-08-04 10:58:49 +02:00
parent e2ed512bbb
commit 42bdee1e5f
2 changed files with 27 additions and 65 deletions
Download Patch File Download Diff File Expand all files Collapse all files

47
src/compiler/GF/Compile/GrammarToLPGF.hs
View File

@@ -71,26 +71,11 @@ mkConcrete debug (C.Abstract _ _ _ funs) (C.Concrete modId absModId flags params
lindefs :: [C.LinDef] lindefs :: [C.LinDef]
lindefs = lindefs =
[ C.LinDef funId varIds linValue' [ C.LinDef funId varIds linValue
| (C.LinDef funId varIds linValue) <- lindefs0 | (C.LinDef funId varIds linValue) <- lindefs0
, let Right linType = lookupLinType funId , let Right linType = lookupLinType funId
, let linValue' = cleanupRecordFields linValue linType
] ]
-- Filter out record fields from definitions which don't appear in lincat.
-- Workaround for https://github.com/GrammaticalFramework/gf-core/issues/101
cleanupRecordFields :: C.LinValue -> C.LinType -> C.LinValue
cleanupRecordFields (C.RecordValue rrvs) (C.RecordType rrs) =
let defnFields = Map.fromList [ (lid, lt) | (C.RecordRow lid lt) <- rrs ]
in C.RecordValue
[ C.RecordRow lid lv'
| C.RecordRow lid lv <- rrvs
, Map.member lid defnFields
, let Just lt = Map.lookup lid defnFields
, let lv' = cleanupRecordFields lv lt
]
cleanupRecordFields lv _ = lv
-- Builds maps for lookups -- Builds maps for lookups
paramValueMap :: Map.Map C.ParamId C.ParamDef -- constructor -> definition paramValueMap :: Map.Map C.ParamId C.ParamDef -- constructor -> definition
@@ -102,14 +87,9 @@ mkConcrete debug (C.Abstract _ _ _ funs) (C.Concrete modId absModId flags params
funMap :: Map.Map C.FunId C.FunDef funMap :: Map.Map C.FunId C.FunDef
funMap = Map.fromList [ (fid,d) | d@(C.FunDef fid _) <- funs ] funMap = Map.fromList [ (fid,d) | d@(C.FunDef fid _) <- funs ]
-- | Lookup paramdef, providing dummy fallback when not found -- | Lookup paramdef
-- Workaround for https://github.com/GrammaticalFramework/gf-core/issues/100
lookupParamDef :: C.ParamId -> Either String C.ParamDef lookupParamDef :: C.ParamId -> Either String C.ParamDef
lookupParamDef pid = case Map.lookup pid paramValueMap of lookupParamDef pid = m2e (printf "Cannot find param definition: %s" (show pid)) (Map.lookup pid paramValueMap)
Just d -> Right d
Nothing ->
-- Left $ printf "Cannot find param definition: %s" (show pid)
Right $ C.ParamDef (C.ParamId (C.Unqual (rawIdentS "DUMMY"))) [C.Param pid []]
-- | Lookup lintype for a function -- | Lookup lintype for a function
lookupLinType :: C.FunId -> Either String C.LinType lookupLinType :: C.FunId -> Either String C.LinType
@@ -181,9 +161,8 @@ mkConcrete debug (C.Abstract _ _ _ funs) (C.Concrete modId absModId flags params
x -> Left $ printf "Unknown predef function: %s" x x -> Left $ printf "Unknown predef function: %s" x
C.RecordValue rrvs -> do C.RecordValue rrvs -> do
let rrvs' = sortRecordRows rrvs ts <- sequence [ val2lin lv | C.RecordRow lid lv <- rrvs ]
ts <- sequence [ val2lin lv | C.RecordRow lid lv <- rrvs' ] return (L.Tuple (map fst ts), Just $ C.RecordType [ C.RecordRow lid lt | (C.RecordRow lid _, (_, Just lt)) <- zip rrvs ts])
return (L.Tuple (map fst ts), Just $ C.RecordType [ C.RecordRow lid lt | (C.RecordRow lid _, (_, Just lt)) <- zip rrvs' ts])
C.TableValue lt trvs -> do C.TableValue lt trvs -> do
-- group the rows by "left-most" value -- group the rows by "left-most" value
@@ -326,22 +305,6 @@ inlineParamAliases defs = if null aliases then defs else map rp' pdefs
Just (C.ParamAliasDef _ (C.ParamType (C.ParamTypeId p))) -> p Just (C.ParamAliasDef _ (C.ParamType (C.ParamTypeId p))) -> p
_ -> pid _ -> pid
-- | Always put 's' reocord field first, then sort alphabetically.
-- Workaround for https://github.com/GrammaticalFramework/gf-core/issues/102
-- Based on GF.Granmar.Macros.sortRec
sortRecordRows :: [C.RecordRowValue] -> [C.RecordRowValue]
sortRecordRows = L.sortBy ordLabel
where
ordLabel (C.RecordRow (C.LabelId l1) _) (C.RecordRow (C.LabelId l2) _) =
case (showRawIdent l1, showRawIdent l2) of
("s",_) -> LT
(_,"s") -> GT
(s1,s2) -> compare s1 s2
-- sortRecord :: C.LinValue -> C.LinValue
-- sortRecord (C.RecordValue rrvs) = C.RecordValue (sortRecordRows rrvs)
-- sortRecord lv = lv
isParamAliasDef :: C.ParamDef -> Bool isParamAliasDef :: C.ParamDef -> Bool
isParamAliasDef (C.ParamAliasDef _ _) = True isParamAliasDef (C.ParamAliasDef _ _) = True
isParamAliasDef _ = False isParamAliasDef _ = False

45
testsuite/lpgf/README.md
View File

@@ -1,25 +1,24 @@
# LPGF testsuite & benchmark # LPGF testsuite & benchmark
## Test ## Testsuite
LPGF must be equivalent to PGF in terms of linearisation output. LPGF must be equivalent to PGF in terms of linearisation output.
Possible exceptions: Possible exceptions:
- No handling of variants (design choice) - No handling of variants (design choice)
- Rendering of missing fucntions - Rendering of missing functions
**N.B.**
Phrasebook doesn't compile with RGL after 1131058b68c204a8d1312d2e2a610748eb8032cb
### Running ### Running
``` ```
stack build --test --bench --no-run-tests --no-run-benchmarks stack build --work-dir .stack-work-test --test --no-run-tests
stack test gf:test:lpgf # all LPGF tests stack test --work-dir .stack-work-test gf:test:lpgf # all LPGF tests
stack test gf:test:lpgf --test-arguments="unittests/Params" # specific grammar stack test --work-dir .stack-work-test gf:test:lpgf --test-arguments="unittests/Params" # specific grammar
stack test gf:test:lpgf --test-arguments="foods/Foods Fre Ger" # specific grammar and languages stack test --work-dir .stack-work-test gf:test:lpgf --test-arguments="foods/Foods Fre Ger" # specific grammar and languages
``` stack test --work-dir .stack-work-test gf:test:lpgf --test-arguments="phrasebook/Phrasebook"
```
stack build --test --bench --no-run-tests --no-run-benchmarks && DEBUG=1 stack test gf:test:lpgf --test-arguments="foods/Foods Fre Ger"
stack build --test --bench --no-run-tests --no-run-benchmarks && DEBUG=1 stack test gf:test:lpgf --test-arguments="phrasebook/Phrasebook Bul"
``` ```
Set environment variable `DEBUG=1` to enable dumping of intermediate formats. Set environment variable `DEBUG=1` to enable dumping of intermediate formats.
@@ -49,21 +48,21 @@ Run each command separately so that memory measurements are isolated.
The `+RTS -T -RTS` is so that GHC can report its own memory usage. The `+RTS -T -RTS` is so that GHC can report its own memory usage.
``` ```
stack build --test --bench --no-run-tests --no-run-benchmarks && stack build --work-dir .stack-work-bench --bench --no-run-benchmarks &&
stack bench --benchmark-arguments "compile pgf testsuite/lpgf/foods/Foods*.gf +RTS -T -RTS" && stack bench --work-dir .stack-work-bench --benchmark-arguments "compile pgf testsuite/lpgf/foods/Foods*.gf +RTS -T -RTS" &&
stack bench --benchmark-arguments "compile lpgf testsuite/lpgf/foods/Foods*.gf +RTS -T -RTS" && stack bench --work-dir .stack-work-bench --benchmark-arguments "compile lpgf testsuite/lpgf/foods/Foods*.gf +RTS -T -RTS" &&
stack bench --benchmark-arguments "run pgf Foods.pgf testsuite/lpgf/foods/Foods-all.trees +RTS -T -RTS" && stack bench --work-dir .stack-work-bench --benchmark-arguments "run pgf Foods.pgf testsuite/lpgf/foods/Foods-all.trees +RTS -T -RTS" &&
stack bench --benchmark-arguments "run pgf2 Foods.pgf testsuite/lpgf/foods/Foods-all.trees +RTS -T -RTS" && stack bench --work-dir .stack-work-bench --benchmark-arguments "run pgf2 Foods.pgf testsuite/lpgf/foods/Foods-all.trees +RTS -T -RTS" &&
stack bench --benchmark-arguments "run lpgf Foods.lpgf testsuite/lpgf/foods/Foods-all.trees +RTS -T -RTS" stack bench --work-dir .stack-work-bench --benchmark-arguments "run lpgf Foods.lpgf testsuite/lpgf/foods/Foods-all.trees +RTS -T -RTS"
``` ```
``` ```
stack build --test --bench --no-run-tests --no-run-benchmarks && stack build --work-dir .stack-work-bench --bench --no-run-benchmarks &&
stack bench --benchmark-arguments "compile pgf testsuite/lpgf/phrasebook/Phrasebook*.gf +RTS -T -RTS" && stack bench --work-dir .stack-work-bench --benchmark-arguments "compile pgf testsuite/lpgf/phrasebook/Phrasebook*.gf +RTS -T -RTS" &&
stack bench --benchmark-arguments "compile lpgf testsuite/lpgf/phrasebook/Phrasebook*.gf +RTS -T -RTS" && stack bench --work-dir .stack-work-bench --benchmark-arguments "compile lpgf testsuite/lpgf/phrasebook/Phrasebook*.gf +RTS -T -RTS" &&
stack bench --benchmark-arguments "run pgf Phrasebook.pgf testsuite/lpgf/phrasebook/Phrasebook-10000.trees +RTS -T -RTS" && stack bench --work-dir .stack-work-bench --benchmark-arguments "run pgf Phrasebook.pgf testsuite/lpgf/phrasebook/Phrasebook-10000.trees +RTS -T -RTS" &&
stack bench --benchmark-arguments "run pgf2 Phrasebook.pgf testsuite/lpgf/phrasebook/Phrasebook-10000.trees +RTS -T -RTS" && stack bench --work-dir .stack-work-bench --benchmark-arguments "run pgf2 Phrasebook.pgf testsuite/lpgf/phrasebook/Phrasebook-10000.trees +RTS -T -RTS" &&
stack bench --benchmark-arguments "run lpgf Phrasebook.lpgf testsuite/lpgf/phrasebook/Phrasebook-10000.trees +RTS -T -RTS" stack bench --work-dir .stack-work-bench --benchmark-arguments "run lpgf Phrasebook.lpgf testsuite/lpgf/phrasebook/Phrasebook-10000.trees +RTS -T -RTS"
``` ```
## Profiling ## Profiling