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

More work on params: pass all tests except params1 (!)

Browse Source
This commit is contained in:
John J. Camilleri
2021-02-27 23:13:02 +01:00
parent f42b5ec9ef
commit 83bc3c9c6e
10 changed files with 144 additions and 70 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -1,6 +1,6 @@
module GF.Compile.GrammarToLPGF (mkCanon2lpgf) where
import LPGF (LPGF (..))
import LPGF (LPGF (..), LinFun (..))
import qualified LPGF as L
import PGF.CId
@@ -46,14 +46,13 @@ mkCanon2lpgf opts gr am = do
mkAbstract :: C.Abstract -> IOE (CId, L.Abstract)
mkAbstract (C.Abstract modId flags cats funs) = return (mdi2i modId, L.Abstract {})
mkConcrete :: C.Concrete -> IOE (CId, L.Concrete)
mkConcrete :: C.Concrete -> IOE (CId, L.Concrete) -- TODO don't need IO
mkConcrete (C.Concrete modId absModId flags params lincats lindefs) = do
let
(C.Abstract _ _ _ funs) = ab
paramMap = mkParamMap params
paramTuples = mkParamTuples params
-- mapM_ (\(C.ParamDef pid _,ptup) -> putStrLn $ show pid ++ "\n" ++ T.unpack (L.render $ L.pp ptup)) (zip params paramTuples)
-- let
-- mapM_ (\(C.ParamDef (C.ParamId (C.Qual _ pid)) _,ptup) -> putStrLn $ "# " ++ pid ++ "\n" ++ T.unpack (L.render $ L.pp ptup)) (zip params paramTuples)
-- filter out record fields from defn which don't appear in lincat
-- this seems to be an inconsistency in the canonical representation
lindefs' =
@@ -101,16 +100,8 @@ mkCanon2lpgf opts gr am = do
C.ErrorValue err -> return (L.LFError err, Nothing)
-- when param value is known at compile time
-- this case is actually covered below and can be omitted,
-- but will result in smaller LPGF and is thus an optimisation
C.ParamConstant _ | isParamConstant lv -> do
(gix,ix) <- [ (gix,ix) | (gix,lvs) <- zip [0..] paramMap, Just ix <- [elemIndex lv lvs] ]
`headOrLeft` printf "Cannot find param value: %s" (show lv)
let (C.ParamDef tpid _) = params !! gix
return (L.LFInt (ix+1), Just $ C.ParamType (C.ParamTypeId tpid))
-- when param value is dynamic
-- the expressions built here can be quite large,
-- but will be reduced during optimisation if possible
C.ParamConstant (C.Param pid lvs) -> do
let
collectProjections :: C.LinValue -> Either String [L.LinFun]
@@ -231,62 +222,58 @@ inlineParamAliases defs = if null aliases then defs else map rp' pdefs
Just (C.ParamAliasDef _ (C.ParamType (C.ParamTypeId p))) -> p
_ -> pid
-- | Enumerate all param value combinations for looking up index numbers.
-- Used when param value is static (known at compile time)
mkParamMap :: [C.ParamDef] -> [[C.LinValue]]
mkParamMap defs = map mk' pdefs
where
pdefs = inlineParamAliases defs
mk' :: C.ParamDef -> [C.LinValue]
mk' (C.ParamDef _ pids) = concatMap mk'' pids
mk' (C.ParamAliasDef _ _) = error "mkParamMap not implemented for ParamAliasDef"
mk'' :: C.ParamValueDef -> [C.LinValue]
mk'' (C.Param pid []) = [C.ParamConstant (C.Param pid [])]
mk'' (C.Param pid pids) =
[ C.ParamConstant (C.Param pid k) | k <- sequence kids ]
where
kids =
[ mk' def
| p <- pids
, let Just def = L.find (\(C.ParamDef pid _) -> pid == p) pdefs
] :: [[C.LinValue]]
-- | Build nested tuple of param values.
-- Needed when param value is dynamic (known only at run time)
-- | Build nested tuple of param values
mkParamTuples :: [C.ParamDef] -> [L.LinFun]
mkParamTuples defs = map (\def -> CMS.evalState (mk' def) 1) pdefs
mkParamTuples defs = map (addIndexes . mk') pdefs
where
pdefs = inlineParamAliases defs
paramMap = zip defs (mkParamMap defs)
mk' :: C.ParamDef -> CMS.State Int L.LinFun
mk' (C.ParamDef _ pids) = do
ms <- mapM mk'' pids
return $ L.LFTuple ms
mk' :: C.ParamDef -> L.LinFun
mk' (C.ParamDef _ pids) = L.LFTuple $ map mk'' pids
mk' (C.ParamAliasDef _ _) = error "mkParamTuples not implemented for ParamAliasDef"
mk'' :: C.ParamValueDef -> CMS.State Int L.LinFun
mk'' (C.Param _ []) = do
ix <- CMS.get
CMS.modify (+1)
return $ L.LFInt ix
mk'' :: C.ParamValueDef -> L.LinFun
mk'' (C.Param _ []) = LFEmpty -- placeholder for terminal node, replaced later
mk'' x@(C.Param p0 [pid]) = do
mk'' x@(C.Param p0 [pid]) =
let Just def = L.find (\(C.ParamDef p _) -> pid == p) pdefs
mk' def
in mk' def
-- mk'' x@(C.Param p0 [pid1,pid2]) = do
-- let Just (C.ParamDef d1 _) = L.find (\(C.ParamDef p _) -> pid1 == p) pdefs
-- let Just def2 = L.find (\(C.ParamDef p _) -> pid2 == p) pdefs
-- let x = head [ xs | (C.ParamDef d _,xs) <- map2, d == d1 ]
-- L.LFTuple <$> sequence [ mk' def2 | _ <- x ]
mk'' x@(C.Param p0 [pid1,pid2]) =
let
Just def1 = L.find (\(C.ParamDef p _) -> pid1 == p) pdefs
Just def2 = L.find (\(C.ParamDef p _) -> pid2 == p) pdefs
lf1 = mk' def1
lf2 = mk' def2
in replaceEmpty lf2 lf1
mk'' x@(C.Param p0 (pid:pids)) =
let
Just def = L.find (\(C.ParamDef p _) -> pid == p) pdefs
this = mk' def
rest = mk'' (C.Param p0 pids)
in replaceEmpty rest this
-- traverse LinFun term and replace Empty with sequential index
addIndexes :: L.LinFun -> L.LinFun
addIndexes lf = CMS.evalState (num lf) 1
where
num :: L.LinFun -> CMS.State Int L.LinFun
num lf = case lf of
L.LFEmpty -> do
ix <- CMS.get
CMS.modify (+1)
return $ L.LFInt ix
L.LFTuple lfs -> L.LFTuple <$> mapM num lfs
x -> error $ "mkParamTuples.number not implemented for: " ++ show x
-- traverse LinFun term and replace Empty with given term
replaceEmpty :: L.LinFun -> L.LinFun -> L.LinFun
replaceEmpty with tree = case tree of
L.LFEmpty -> with
L.LFTuple lfs -> L.LFTuple $ map (replaceEmpty with) lfs
x -> error $ "mkParamTuples.replaceEmpty not implemented for: " ++ show x
mk'' (C.Param p0 (pid:pids)) = do
let Just (C.ParamDef dpid _) = L.find (\(C.ParamDef p _) -> pid == p) pdefs
let Just (_, lvs) = L.find (\(C.ParamDef d _, lvs) -> dpid == d) paramMap
L.LFTuple <$> sequence [ mk'' (C.Param p0 pids) | _ <- lvs ]
-- | Always put 's' reocord field first, then sort alphabetically
-- This seems to be done inconsistently in the canonical format

9
testsuite/lpgf/test.hs
View File

@@ -22,12 +22,17 @@ main = do
case args of
[] -> do
doGrammar "unittests" "Bind"
doGrammar "unittests" "Tables"
doGrammar "unittests" "Params"
doGrammar "unittests" "Missing"
doGrammar "unittests" "Params1"
doGrammar "unittests" "Params2"
doGrammar "unittests" "Params3"
doGrammar "unittests" "Pre"
doGrammar "unittests" "Projection"
doGrammar "unittests" "Tables"
doGrammar "walking" "Walking"
doGrammar "foods" "Foods"
-- doGrammar "phrasebook" "Phrasebook"
[absname] ->
doGrammar (takeDirectory absname) (takeBaseName absname)
absname:langs ->

5
testsuite/lpgf/unittests/Params.treebank
View File

@@ -1,5 +0,0 @@
Params: FtoS f1
ParamsCnc: PRQ _ Q3
Params: FtoS f2
ParamsCnc: PRQ (RT _) Q1

2
testsuite/lpgf/unittests/Params.gf → testsuite/lpgf/unittests/Params1.gf
View File

@@ -1,4 +1,4 @@
abstract Params = {
abstract Params1 = {
cat S ; F ;
fun
FtoS : F -> S ;

5
testsuite/lpgf/unittests/Params1.treebank Normal file
View File

@@ -0,0 +1,5 @@
Params1: FtoS f1
Params1Cnc: PRQ _ Q3
Params1: FtoS f2
Params1Cnc: PRQ (RT _) Q1

2
testsuite/lpgf/unittests/ParamsCnc.gf → testsuite/lpgf/unittests/Params1Cnc.gf
View File

@@ -1,4 +1,4 @@
concrete ParamsCnc of Params = {
concrete Params1Cnc of Params1 = {
param
P = Px | PRQ R Q | Py ;
R = R0 | RT T ;

1
testsuite/lpgf/unittests/Params2.gf
View File

@@ -1,4 +1,5 @@
abstract Params2 = {
flags startcat = MassKind ;
cat Quality ; MassKind ;
fun
Good : Quality;

14
testsuite/lpgf/unittests/Params3.gf Normal file
View File

@@ -0,0 +1,14 @@
abstract Params3 = {
cat G ; S ;
fun
mkPred : S ;
mkModSgHumanTrue : G -> S ;
mkModSgHumanFalse : G -> S ;
mkModSgNonTrue : S ;
mkModSgNonFalse : S ;
mkModPl : S ;
GMasc : G ;
GFem : G ;
GNeutr : G ;
}

29
testsuite/lpgf/unittests/Params3.treebank Normal file
View File

@@ -0,0 +1,29 @@
Params3: mkModPl
Params3Cnc: mod pl
Params3: mkModSgHumanFalse GFem
Params3Cnc: mod sg human fem f
Params3: mkModSgHumanFalse GMasc
Params3Cnc: mod sg human masc f
Params3: mkModSgHumanFalse GNeutr
Params3Cnc: mod sg human neutr f
Params3: mkModSgHumanTrue GFem
Params3Cnc: mod sg human fem t
Params3: mkModSgHumanTrue GMasc
Params3Cnc: mod sg human masc t
Params3: mkModSgHumanTrue GNeutr
Params3Cnc: mod sg human neutr t
Params3: mkModSgNonFalse
Params3Cnc: mod sg nonhuman f
Params3: mkModSgNonTrue
Params3Cnc: mod sg nonhuman f
Params3: mkPred
Params3Cnc: pred

38
testsuite/lpgf/unittests/Params3Cnc.gf Normal file
View File

@@ -0,0 +1,38 @@
concrete Params3Cnc of Params3 = {
param
Boolean = True | False;
AForm = APred | AMod GenNum;
GenNum = GSg Animacy Boolean | GPl;
Animacy = Human Gender | Nonhuman ;
Gender = Masc | Fem | Neutr;
lincat
S = Str ;
G = { gen : Gender } ;
T = AForm => Str ;
lin
mkPred = tbl ! APred ;
mkModSgHumanTrue g = tbl ! AMod (GSg (Human g.gen) True) ;
mkModSgHumanFalse g = tbl ! AMod (GSg (Human g.gen) False) ;
mkModSgNonTrue = tbl ! AMod (GSg Nonhuman False) ;
mkModSgNonFalse = tbl ! AMod (GSg Nonhuman False) ;
mkModPl = tbl ! AMod GPl ;
GMasc = { gen = Masc } ;
GFem = { gen = Fem } ;
GNeutr = { gen = Neutr } ;
oper
tbl = table {
APred => "pred";
AMod (GSg (Human Masc) True) => "mod sg human masc t";
AMod (GSg (Human Masc) False) => "mod sg human masc f";
AMod (GSg (Human Fem) True) => "mod sg human fem t";
AMod (GSg (Human Fem) False) => "mod sg human fem f";
AMod (GSg (Human Neutr) True) => "mod sg human neutr t";
AMod (GSg (Human Neutr) False) => "mod sg human neutr f";
AMod (GSg Nonhuman True) => "mod sg nonhuman t";
AMod (GSg Nonhuman False) => "mod sg nonhuman f";
AMod GPl => "mod pl"
} ;
}