diff --git a/src/compiler/GF/Compile/GrammarToLPGF.hs b/src/compiler/GF/Compile/GrammarToLPGF.hs index a2d6f8b41..47576d6a5 100644 --- a/src/compiler/GF/Compile/GrammarToLPGF.hs +++ b/src/compiler/GF/Compile/GrammarToLPGF.hs @@ -52,7 +52,8 @@ mkCanon2lpgf opts gr am = do (C.Abstract _ _ _ funs) = ab paramMap = mkParamMap params paramTuples = mkParamTuples params - + -- mapM_ (putStrLn . T.unpack . L.render . L.pp) paramTuples + let -- filter out record fields from defn which don't appear in lincat -- this seems to be an inconsistency in the canonical representation lindefs' = @@ -100,9 +101,9 @@ mkCanon2lpgf opts gr am = do C.ErrorValue err -> return (L.LFError err, Nothing) - -- when param value can be known at compile time - -- this case is actually covered below and can be omitted, but it will result in smaller LPGF - -- and should thus be seen as an optimisation + -- 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) @@ -110,20 +111,46 @@ mkCanon2lpgf opts gr am = do return (L.LFInt (ix+1), Just $ C.ParamType (C.ParamTypeId tpid)) -- when param value is dynamic - C.ParamConstant (C.Param pid pids) -> do + C.ParamConstant (C.Param pid lvs) -> do -- get param group index and defn for this constructor (gix,def) <- [ (gix,d) | (gix,d@(C.ParamDef _ ps)) <- zip [0..] params, any (\(C.Param p _) -> p == pid) ps ] `headOrLeft` printf "Cannot find param group: %s" (show pid) let (C.ParamDef tpid defpids) = def - pidIx <- eitherElemIndex pid [ p | C.Param p _ <- defpids ] - pids' <- mapM val2lin pids + let - tuple = paramTuples !! gix - term = foldl L.LFProjection tuple (L.LFInt (pidIx+1):map fst pids') + collectProjections :: C.LinValue -> Either String [L.LinFun] + collectProjections (C.ParamConstant (C.Param pid lvs)) = do + def <- [ d | d@(C.ParamDef _ ps) <- params, any (\(C.Param p _) -> p == pid) ps ] + `headOrLeft` printf "Cannot find param group: %s" (show pid) + let (C.ParamDef tpid defpids) = def + pidIx <- eitherElemIndex pid [ p | C.Param p _ <- defpids ] + rest <- mapM collectProjections lvs + return $ L.LFInt (pidIx+1) : concat rest + collectProjections lv = do + (lf ,_) <- val2lin lv + return [lf] + + let tuple = paramTuples !! gix + lfs <- collectProjections lv + let term = foldl L.LFProjection tuple lfs + + -- term <- case lvs of + -- [] -> return $ L.LFProjection tuple (L.LFInt (pidIx+1)) + -- [lv0] -> do + -- (lf0,lt0) <- val2lin lv0 + -- return $ L.LFProjection (L.LFProjection tuple (L.LFInt (pidIx+1))) lf0 + -- [lv1,lv2] -> do + -- (lf1,lt1) <- val2lin lv1 + -- (lf2,lt2) <- val2lin lv2 + -- return $ L.LFProjection (L.LFProjection (L.LFProjection tuple (L.LFInt (pidIx+1))) lf1) lf2 + + -- lvs' <- mapM val2lin lvs + -- let term = foldl L.LFProjection tuple (L.LFInt (pidIx+1):map fst lvs') + + -- term = L.LFProjection (L.LFProjection (L.LFProjection (L.LFProjection tuple (L.LFInt 2 {- AMod -})) (L.LFInt 1 {- GSg -})) (L.LFInt 3 {- Neutr -})) (L.LFInt 1 {- True -}) return (term, Just $ C.ParamType (C.ParamTypeId tpid)) - -- https://www.aclweb.org/anthology/W15-3305.pdf C.PredefValue (C.PredefId pid) -> case pid of "BIND" -> return (L.LFBind, Nothing) "SOFT_BIND" -> return (L.LFBind, Nothing) @@ -219,7 +246,8 @@ inlineParamAliases defs = if null aliases then defs else map rp' pdefs Just (C.ParamAliasDef _ (C.ParamType (C.ParamTypeId p))) -> p _ -> pid --- | Enumerate all paramvalue combinations for looking up index numbers +-- | 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 @@ -240,7 +268,8 @@ mkParamMap defs = map mk' pdefs , let Just def = L.find (\(C.ParamDef pid _) -> pid == p) pdefs ] :: [[C.LinValue]] --- | Build LPGF tuple of param values, needed when param index is looked up dynamically +-- | Build nested tuple of param values. +-- Needed when param value is dynamic (known only at run time) mkParamTuples :: [C.ParamDef] -> [L.LinFun] mkParamTuples defs = map (\def -> CMS.evalState (mk' def) 1) pdefs where @@ -257,15 +286,24 @@ mkParamTuples defs = map (\def -> CMS.evalState (mk' def) 1) pdefs ix <- CMS.get CMS.modify (+1) return $ L.LFInt ix + + mk'' x@(C.Param p0 [pid]) = do + let Just def = L.find (\(C.ParamDef p _) -> pid == p) pdefs + mk' def + + -- mk'' x@(C.Param p0 [pid1,pid2]) = do + -- let Just def1 = L.find (\(C.ParamDef p _) -> pid1 == p) pdefs + -- let Just def2 = L.find (\(C.ParamDef p _) -> pid2 == p) pdefs + -- let m1 = CMS.evalState (mk' def1) 1 -- get shape without affecting our counter + -- -- m2 <- mk' def2 + -- let LFTuple m1' = m1 + -- -- let LFTuple m2' = m2 + -- L.LFTuple <$> sequence [ mk' def2 | _ <- m1' ] + mk'' (C.Param p0 (pid:pids)) = do let Just def = L.find (\(C.ParamDef p _) -> pid == p) pdefs - let ms = CMS.evalState (mk' def) 1 - let L.LFTuple ms' = ms - ns <- sequence - [ mk'' (C.Param p0 pids) - | m <- ms' - ] - return $ L.LFTuple ns + let L.LFTuple ms = CMS.evalState (mk' def) 1 -- get shape without affecting our counter + L.LFTuple <$> sequence [ mk'' (C.Param p0 pids) | _ <- ms ] -- | Always put 's' reocord field first, then sort alphabetically -- This seems to be done inconsistently in the canonical format diff --git a/src/runtime/haskell/LPGF.hs b/src/runtime/haskell/LPGF.hs index 7c9386574..ea0122d2e 100644 --- a/src/runtime/haskell/LPGF.hs +++ b/src/runtime/haskell/LPGF.hs @@ -272,9 +272,14 @@ instance PP LinFun where CMW.tell [ T.replicate (n+1) " " `T.append` T.pack (show p) | p <- ps ] pp' (n+1) d - c@(LFConcat l1 l2) | isDeep l1 || isDeep l2 -> do - p "LFConcat" - mapM_ (pp' (n+1)) (unConcat c) + c@(LFConcat l1 l2) -> do + let ts = unConcat c + if any isDeep ts + then do + p "LFConcat" + mapM_ (pp' (n+1)) ts + else + ps $ "LFConcat " ++ show ts LFTuple ls | any isDeep ls -> do p "LFTuple" mapM_ (pp' (n+1)) ls diff --git a/testsuite/lpgf/unittests/Params.treebank b/testsuite/lpgf/unittests/Params.treebank index 12e3a2c15..b1f7156ee 100644 --- a/testsuite/lpgf/unittests/Params.treebank +++ b/testsuite/lpgf/unittests/Params.treebank @@ -1,5 +1,5 @@ Params: FtoS f1 -ParamsCnc: PR R1 Q1 +ParamsCnc: PRQ _ Q3 Params: FtoS f2 -ParamsCnc: PR R2 _ +ParamsCnc: PRQ (RT _) Q1 diff --git a/testsuite/lpgf/unittests/Params2.treebank b/testsuite/lpgf/unittests/Params2.treebank index 1ef424ed0..6ff1b3160 100644 --- a/testsuite/lpgf/unittests/Params2.treebank +++ b/testsuite/lpgf/unittests/Params2.treebank @@ -1,2 +1,2 @@ Params2: SuchMassKind Good -Params2Cnc: gutes +Params2Cnc: mod sg neutr t diff --git a/testsuite/lpgf/unittests/Params2Cnc.gf b/testsuite/lpgf/unittests/Params2Cnc.gf index f1843678e..393aa7e74 100644 --- a/testsuite/lpgf/unittests/Params2Cnc.gf +++ b/testsuite/lpgf/unittests/Params2Cnc.gf @@ -1,8 +1,9 @@ concrete Params2Cnc of Params2 = { param + Boolean = True | False; AForm = APred | AMod GenNum; - GenNum = GSg Gender | GPl; + GenNum = GSg Gender Boolean | GPl; Gender = Masc | Fem | Neutr; lincat @@ -11,16 +12,19 @@ concrete Params2Cnc of Params2 = { lin SuchMassKind qual = { - s = qual.s ! AMod (GSg qual.g) + s = qual.s ! AMod (GSg qual.g True) }; Good = { s = - table {APred => "gut"; - AMod (GSg Masc) => "guter"; - AMod (GSg Fem) => "gute"; - AMod (GSg Neutr) => "gutes"; - AMod GPl => "gute"} ; + table {APred => "pred"; + AMod (GSg Masc True) => "mod sg masc t"; + AMod (GSg Fem True) => "mod sg fem t"; + AMod (GSg Neutr True) => "mod sg neutr t"; + AMod (GSg Masc False) => "mod sg masc f"; + AMod (GSg Fem False) => "mod sg fem f"; + AMod (GSg Neutr False) => "mod sg neutr f"; + AMod GPl => "mod pl"} ; g = Neutr }; } diff --git a/testsuite/lpgf/unittests/ParamsCnc.gf b/testsuite/lpgf/unittests/ParamsCnc.gf index d0b12c1d0..5b4632396 100644 --- a/testsuite/lpgf/unittests/ParamsCnc.gf +++ b/testsuite/lpgf/unittests/ParamsCnc.gf @@ -1,21 +1,30 @@ concrete ParamsCnc of Params = { param - R = R1 | R2 ; - P = PR R Q | PP ; + P = Px | PRQ R Q | Py ; + R = R0 | RT T ; + T = T0 | T1 ; Q = Q3 | Q2 | Q1 ; lincat S = Str ; - F = { r : R } ; + F = { r : R; q : Q } ; lin - f1 = { r = R1 } ; - f2 = { r = R2 } ; - FtoS f = tbl ! PR f.r Q1 ; + f1 = { r = R0 ; q = Q3 } ; + f2 = { r = RT T1 ; q = Q1 } ; + FtoS f = tbl ! PRQ f.r f.q ; oper tbl = table { - PR R1 Q2 => "PR R1 Q2" ; - PR R1 Q1 => "PR R1 Q1" ; - PR R1 Q3 => "PR R1 Q3" ; - PR R2 _ => "PR R2 _" ; - PP => "PP" + Px => "Px" ; + Py => "Py" ; + PRQ R0 Q1 => "PRQ R0 Q1" ; + PRQ R0 Q2 => "PRQ R0 Q2" ; + -- PRQ R0 Q3 => "PRQ R0 Q3" ; + PRQ (RT _) Q1 => "PRQ (RT _) Q1" ; + -- PRQ (RT T0) Q1 => "PRQ (RT T0) Q1" ; + PRQ (RT T0) Q2 => "PRQ (RT T0) Q2" ; + -- PRQ (RT T0) Q3 => "PRQ (RT T0) Q3" ; + -- PRQ (RT T1) Q1 => "PRQ (RT T1) Q1" ; + PRQ (RT T1) Q2 => "PRQ (RT T1) Q2" ; + -- PRQ (RT T1) Q3 => "PRQ (RT T1) Q3" ; + PRQ _ Q3 => "PRQ _ Q3" } ; }