diff --git a/src/compiler/GF/Compile/GrammarToLPGF.hs b/src/compiler/GF/Compile/GrammarToLPGF.hs index 9bfdd91ae..d22fbb21e 100644 --- a/src/compiler/GF/Compile/GrammarToLPGF.hs +++ b/src/compiler/GF/Compile/GrammarToLPGF.hs @@ -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 diff --git a/testsuite/lpgf/test.hs b/testsuite/lpgf/test.hs index 196b98e8a..761aa70d5 100644 --- a/testsuite/lpgf/test.hs +++ b/testsuite/lpgf/test.hs @@ -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 -> diff --git a/testsuite/lpgf/unittests/Params.treebank b/testsuite/lpgf/unittests/Params.treebank deleted file mode 100644 index b1f7156ee..000000000 --- a/testsuite/lpgf/unittests/Params.treebank +++ /dev/null @@ -1,5 +0,0 @@ -Params: FtoS f1 -ParamsCnc: PRQ _ Q3 - -Params: FtoS f2 -ParamsCnc: PRQ (RT _) Q1 diff --git a/testsuite/lpgf/unittests/Params.gf b/testsuite/lpgf/unittests/Params1.gf similarity index 76% rename from testsuite/lpgf/unittests/Params.gf rename to testsuite/lpgf/unittests/Params1.gf index 0fbc5b011..03b73ac06 100644 --- a/testsuite/lpgf/unittests/Params.gf +++ b/testsuite/lpgf/unittests/Params1.gf @@ -1,4 +1,4 @@ -abstract Params = { +abstract Params1 = { cat S ; F ; fun FtoS : F -> S ; diff --git a/testsuite/lpgf/unittests/Params1.treebank b/testsuite/lpgf/unittests/Params1.treebank new file mode 100644 index 000000000..a482aa00d --- /dev/null +++ b/testsuite/lpgf/unittests/Params1.treebank @@ -0,0 +1,5 @@ +Params1: FtoS f1 +Params1Cnc: PRQ _ Q3 + +Params1: FtoS f2 +Params1Cnc: PRQ (RT _) Q1 diff --git a/testsuite/lpgf/unittests/ParamsCnc.gf b/testsuite/lpgf/unittests/Params1Cnc.gf similarity index 95% rename from testsuite/lpgf/unittests/ParamsCnc.gf rename to testsuite/lpgf/unittests/Params1Cnc.gf index 5b4632396..b44e35c28 100644 --- a/testsuite/lpgf/unittests/ParamsCnc.gf +++ b/testsuite/lpgf/unittests/Params1Cnc.gf @@ -1,4 +1,4 @@ -concrete ParamsCnc of Params = { +concrete Params1Cnc of Params1 = { param P = Px | PRQ R Q | Py ; R = R0 | RT T ; diff --git a/testsuite/lpgf/unittests/Params2.gf b/testsuite/lpgf/unittests/Params2.gf index 2d4c272b9..2b1e218d0 100644 --- a/testsuite/lpgf/unittests/Params2.gf +++ b/testsuite/lpgf/unittests/Params2.gf @@ -1,4 +1,5 @@ abstract Params2 = { + flags startcat = MassKind ; cat Quality ; MassKind ; fun Good : Quality; diff --git a/testsuite/lpgf/unittests/Params3.gf b/testsuite/lpgf/unittests/Params3.gf new file mode 100644 index 000000000..50dd846f8 --- /dev/null +++ b/testsuite/lpgf/unittests/Params3.gf @@ -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 ; +} diff --git a/testsuite/lpgf/unittests/Params3.treebank b/testsuite/lpgf/unittests/Params3.treebank new file mode 100644 index 000000000..30305a5f8 --- /dev/null +++ b/testsuite/lpgf/unittests/Params3.treebank @@ -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 diff --git a/testsuite/lpgf/unittests/Params3Cnc.gf b/testsuite/lpgf/unittests/Params3Cnc.gf new file mode 100644 index 000000000..fb5b9f9ea --- /dev/null +++ b/testsuite/lpgf/unittests/Params3Cnc.gf @@ -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" + } ; +}