From 4c09e4a3408649d5f670cae4e6df6e0f2bb54fab Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Wed, 3 Mar 2021 09:19:52 +0100 Subject: [PATCH] Remove LF prefix from constructors. Pass all unit tests and Foods again, but improvements/cleanup still necessary. --- src/compiler/GF/Compile/GrammarToLPGF.hs | 140 +++++++++++------ src/runtime/haskell/LPGF.hs | 186 ++++++++++++----------- testsuite/lpgf/unittests/Tables.gf | 2 +- testsuite/lpgf/unittests/Tables.treebank | 18 +++ testsuite/lpgf/unittests/TablesCnc.gf | 1 + 5 files changed, 208 insertions(+), 139 deletions(-) diff --git a/src/compiler/GF/Compile/GrammarToLPGF.hs b/src/compiler/GF/Compile/GrammarToLPGF.hs index 21c160943..15b0345d5 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 (..), LinFun (..)) +import LPGF (LPGF (..)) import qualified LPGF as L import PGF.CId @@ -46,12 +46,14 @@ 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) -- TODO don't need IO - mkConcrete (C.Concrete modId absModId flags params lincats lindefs) = do + mkConcrete :: C.Concrete -> IOE (CId, L.Concrete) -- TODO don't need IO, use ErrM + mkConcrete (C.Concrete modId absModId flags params' lincats lindefs) = do let (C.Abstract _ _ _ funs) = ab - paramTuples = mkParamTuples params + params = inlineParamAliases params' -- TODO remove by making mkParamTuples return map + paramTuples = mkParamTuples params' -- mapM_ (\(C.ParamDef (C.ParamId (C.Qual _ pid)) _,ptup) -> putStrLn $ "# " ++ pid ++ "\n" ++ T.unpack (L.render $ L.pp ptup)) (zip params paramTuples) + let -- filter out record fields from defn which don't appear in lincat -- this seems to be an inconsistency in the canonical representation @@ -91,14 +93,14 @@ mkCanon2lpgf opts gr am = do C.ConcatValue v1 v2 -> do (v1',t1) <- val2lin v1 (v2',t2) <- val2lin v2 - return (L.LFConcat v1' v2', t1 <|> t2) -- t1 else t2 + return (L.Concat v1' v2', t1 <|> t2) -- t1 else t2 C.LiteralValue ll -> case ll of - C.FloatConstant f -> return (L.LFToken $ T.pack $ show f, Just C.FloatType) - C.IntConstant i -> return (L.LFToken $ T.pack $ show i, Just C.IntType) - C.StrConstant s -> return (L.LFToken $ T.pack s, Just C.StrType) + C.FloatConstant f -> return (L.Token $ T.pack $ show f, Just C.FloatType) + C.IntConstant i -> return (L.Token $ T.pack $ show i, Just C.IntType) + C.StrConstant s -> return (L.Token $ T.pack s, Just C.StrType) - C.ErrorValue err -> return (L.LFError err, Nothing) + C.ErrorValue err -> return (L.Error err, Nothing) -- the expressions built here can be quite large, -- but will be reduced during optimisation if possible @@ -111,9 +113,9 @@ mkCanon2lpgf opts gr am = do 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 + return $ L.Ix (pidIx+1) : concat rest collectProjections lv = do - (lf ,_) <- val2lin lv + (lf,_) <- val2lin lv return [lf] -- get param group index and defn for this constructor @@ -121,24 +123,45 @@ mkCanon2lpgf opts gr am = do `headOrLeft` printf "Cannot find param group: %s" (show pid) let (C.ParamDef tpid _) = def - let tuple = paramTuples !! gix + -- let tuple = paramTuples !! gix lfs <- collectProjections lv - let term = foldl L.LFProjection tuple lfs + -- let term = foldl L.Projection tuple lfs + let term = L.Tuple lfs -- unapplied! return (term, Just $ C.ParamType (C.ParamTypeId tpid)) + C.Selection v1 v2 -> do + (v1', t1) <- val2lin v1 + (v2', t2) <- val2lin v2 + -- let Just (C.TableType t11 t12) = t1 -- t11 == t2 + + case t1 of + Just (C.TableType (C.ParamType (C.ParamTypeId pid)) tret) -> do + (gix,_) <- [ (gix,d) | (gix,d@(C.ParamDef p _)) <- zip [0..] params, p == pid ] + `headOrLeft` printf "Cannot find param group: %s" (show pid) + let tuple = paramTuples !! gix + let v2'' = case v2' of + L.Tuple lfs -> foldl L.Projection tuple lfs + lf -> L.Projection tuple lf + return (L.Projection v1' v2'', Just tret) + + Just (C.TableType (C.RecordType rrts) tret) -> + return (L.Projection v1' v2', Just tret) + + _ -> Left $ printf "Unhandled type in selection: %s" (show t1) + C.PredefValue (C.PredefId pid) -> case pid of - "BIND" -> return (L.LFBind, Nothing) - "SOFT_BIND" -> return (L.LFBind, Nothing) - "SOFT_SPACE" -> return (L.LFSpace, Nothing) - "CAPIT" -> return (L.LFCapit, Nothing) - "ALL_CAPIT" -> return (L.LFAllCapit, Nothing) + "BIND" -> return (L.Bind, Nothing) + "SOFT_BIND" -> return (L.Bind, Nothing) + "SOFT_SPACE" -> return (L.Space, Nothing) + "CAPIT" -> return (L.Capit, Nothing) + "ALL_CAPIT" -> return (L.AllCapit, Nothing) _ -> Left $ printf "Unknown predef function: %s" pid C.RecordValue rrvs -> do let rrvs' = sortRecordRows rrvs ts <- sequence [ val2lin lv | C.RecordRow lid lv <- rrvs' ] - return (L.LFTuple (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 | isRecordType lt -> go trvs where @@ -147,32 +170,38 @@ mkCanon2lpgf opts gr am = do go trvs = do let grps = L.groupBy (\(C.TableRow (C.RecordPattern rps1) _) (C.TableRow (C.RecordPattern rps2) _) -> head rps1 == head rps2) trvs ts <- mapM (go . map (\(C.TableRow (C.RecordPattern rps) lv) -> C.TableRow (C.RecordPattern (tail rps)) lv)) grps - return (L.LFTuple (map fst ts), Just lt) + let typ = case ts of + (_, Just tst):_ -> Just $ C.TableType lt tst + _ -> Nothing + return (L.Tuple (map fst ts), typ) C.TableValue lt trvs | isParamType lt -> do ts <- sequence [ val2lin lv | C.TableRow _ lv <- trvs ] - return (L.LFTuple (map fst ts), Just lt) + let typ = case ts of + (_, Just tst):_ -> Just $ C.TableType lt tst + _ -> Nothing + return (L.Tuple (map fst ts), typ) -- TODO TuplePattern, WildPattern? C.TupleValue lvs -> do ts <- mapM val2lin lvs - return (L.LFTuple (map fst ts), Just $ C.TupleType (map (fromJust.snd) ts)) + return (L.Tuple (map fst ts), Just $ C.TupleType (map (fromJust.snd) ts)) - C.VariantValue [] -> return (L.LFEmpty, Nothing) + C.VariantValue [] -> return (L.Empty, Nothing) C.VariantValue (vr:_) -> val2lin vr -- NOTE variants not supported, just pick first C.VarValue (C.VarValueId (C.Unqual v)) -> do ix <- eitherElemIndex (C.VarId v) varIds lt <- lookupLinTypeArg funId ix - return (L.LFArgument (ix+1), Just lt) + return (L.Argument (ix+1), Just lt) C.PreValue pts df -> do pts' <- forM pts $ \(pfxs, lv) -> do (lv', _) <- val2lin lv return (map T.pack pfxs, lv') (df', lt) <- val2lin df - return (L.LFPre pts' df', lt) + return (L.Pre pts' df', lt) C.Projection v1 lblId -> do (v1', mtyp) <- val2lin v1 @@ -186,13 +215,13 @@ mkCanon2lpgf opts gr am = do Left _ -> 0 -- corresponds to Prelude.False -- lookup lintype for record row let C.RecordRow _ lt = rrs !! lblIx - return (L.LFProjection v1' (L.LFInt (lblIx+1)), Just lt) + return (L.Projection v1' (L.Ix (lblIx+1)), Just lt) - C.Selection v1 v2 -> do - (v1', t1) <- val2lin v1 - (v2', t2) <- val2lin v2 - let Just (C.TableType t11 t12) = t1 - return (L.LFProjection v1' v2', Just t12) + -- C.Selection v1 v2 -> do + -- (v1', t1) <- val2lin v1 + -- (v2', t2) <- val2lin v2 + -- let Just (C.TableType t11 t12) = t1 + -- return (L.Projection v1' v2', Just t12) C.CommentedValue cmnt lv -> val2lin lv @@ -229,15 +258,15 @@ mkParamTuples defs = map (addIndexes . mk') pdefs pdefs = inlineParamAliases defs mk' :: C.ParamDef -> L.LinFun - mk' (C.ParamDef _ pids) = L.LFTuple $ map mk'' pids + mk' (C.ParamDef _ pids) = L.Tuple $ map mk'' pids mk' (C.ParamAliasDef _ _) = error "mkParamTuples not implemented for ParamAliasDef" mk'' :: C.ParamValueDef -> L.LinFun - mk'' (C.Param _ []) = LFEmpty -- placeholder for terminal node, replaced later + mk'' (C.Param _ []) = L.Empty -- placeholder for terminal node, replaced later - mk'' x@(C.Param p0 [pid]) = - let Just def = L.find (\(C.ParamDef p _) -> pid == p) pdefs - in mk' def + -- mk'' x@(C.Param p0 [pid]) = + -- let Just def = L.find (\(C.ParamDef p _) -> pid == p) pdefs + -- in mk' def -- mk'' x@(C.Param p0 [pid1,pid2]) = -- let @@ -254,27 +283,26 @@ mkParamTuples defs = map (addIndexes . mk') pdefs rest = mk'' (C.Param p0 pids) in replaceEmpty rest this - -- traverse LinFun term and replace Empty with sequential index + -- | 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 + L.Empty -> do ix <- CMS.get CMS.modify (+1) - return $ L.LFInt ix - L.LFTuple lfs -> L.LFTuple <$> mapM num lfs + return $ L.Ix ix + L.Tuple lfs -> L.Tuple <$> mapM num lfs x -> error $ "mkParamTuples.number not implemented for: " ++ show x - -- traverse LinFun term and replace Empty with given term + -- | 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 + L.Empty -> with + L.Tuple lfs -> L.Tuple $ map (replaceEmpty with) lfs x -> error $ "mkParamTuples.replaceEmpty not implemented for: " ++ show x - -- | Always put 's' reocord field first, then sort alphabetically -- This seems to be done inconsistently in the canonical format -- Based on GF.Granmar.Macros.sortRec @@ -308,16 +336,32 @@ isParamConstant :: C.LinValue -> Bool isParamConstant (C.ParamConstant (C.Param _ lvs)) = all isParamConstant lvs isParamConstant _ = False -isLFInt :: L.LinFun -> Bool -isLFInt (L.LFInt _) = True -isLFInt _ = False +isIx :: L.LinFun -> Bool +isIx (L.Ix _) = True +isIx _ = False + +-- | Minimise a linfun by evaluating projections where possible +-- This code closely matches the runtime's `eval` function, except we have no context +reduce :: L.LinFun -> L.LinFun +reduce lf = case lf of + L.Pre pts df -> L.Pre pts' df' + where + pts' = [ (strs,reduce t) | (strs,t) <- pts] + df' = reduce df + L.Concat s t -> L.Concat (reduce s) (reduce t) + L.Tuple ts -> L.Tuple (map reduce ts) + L.Projection t u -> + case (reduce t, reduce u) of + (L.Tuple vs, L.Ix i) -> reduce $ vs !! (i-1) + (tp@(L.Tuple _), L.Tuple is) | all L.isIx is -> foldl (\(L.Tuple vs) (L.Ix i) -> vs !! (i-1)) tp is + (t',u') -> L.Projection t' u' + t -> t -- | If list is non-empty return its head, else a fallback value headOrLeft :: [a] -> b -> Either b a headOrLeft (a:_) _ = Right a headOrLeft _ b = Left b - -- | Convert Maybe to Either value with error m2e :: String -> Maybe a -> Either String a m2e err = maybe (Left err) Right diff --git a/src/runtime/haskell/LPGF.hs b/src/runtime/haskell/LPGF.hs index 70f8e0c3d..f0695f418 100644 --- a/src/runtime/haskell/LPGF.hs +++ b/src/runtime/haskell/LPGF.hs @@ -4,6 +4,7 @@ -- | Linearisation-only grammar format. -- Closely follows description in Section 2 of Angelov, Bringert, Ranta (2009): -- "PGF: A Portable Run-Time Format for Type-Theoretical Grammars". +-- http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.640.6330&rep=rep1&type=pdf module LPGF where import PGF (Language) @@ -46,30 +47,30 @@ newtype Concrete = Concrete { -- -- | Linearisation type -- data LinType = --- LTStr --- | LTInt Int --- | LTProduct [LinType] +-- StrType +-- | IxType Int +-- | ProductType [LinType] -- deriving (Show) -- | Linearisation function data LinFun = -- Additions - LFError String -- ^ a runtime error, should probably not be supported at all - | LFBind -- ^ join adjacent tokens - | LFSpace -- ^ space between adjacent tokens - | LFCapit -- ^ capitalise next character - | LFAllCapit -- ^ capitalise next word - | LFPre [([Text], LinFun)] LinFun - | LFMissing CId -- ^ missing definition (inserted at runtime) + Error String -- ^ a runtime error, should probably not be supported at all + | Bind -- ^ join adjacent tokens + | Space -- ^ space between adjacent tokens + | Capit -- ^ capitalise next character + | AllCapit -- ^ capitalise next word + | Pre [([Text], LinFun)] LinFun + | Missing CId -- ^ missing definition (inserted at runtime) -- From original definition in paper - | LFEmpty - | LFToken Text - | LFConcat LinFun LinFun - | LFInt Int - | LFTuple [LinFun] - | LFProjection LinFun LinFun - | LFArgument Int + | Empty + | Token Text + | Concat LinFun LinFun + | Ix Int + | Tuple [LinFun] + | Projection LinFun LinFun + | Argument Int deriving (Show, Read) instance Binary LPGF where @@ -101,37 +102,37 @@ instance Binary Concrete where instance Binary LinFun where put = \case - LFError e -> putWord8 0 >> put e - LFBind -> putWord8 1 - LFSpace -> putWord8 2 - LFCapit -> putWord8 3 - LFAllCapit -> putWord8 4 - LFPre ps d -> putWord8 5 >> put ([(map TE.encodeUtf8 p,l) | (p,l) <- ps],d) - LFMissing f -> putWord8 13 >> put f - LFEmpty -> putWord8 6 - LFToken t -> putWord8 7 >> put (TE.encodeUtf8 t) - LFConcat l1 l2 -> putWord8 8 >> put (l1,l2) - LFInt i -> putWord8 9 >> put i - LFTuple ls -> putWord8 10 >> put ls - LFProjection l1 l2 -> putWord8 11 >> put (l1,l2) - LFArgument i -> putWord8 12 >> put i + Error e -> putWord8 0 >> put e + Bind -> putWord8 1 + Space -> putWord8 2 + Capit -> putWord8 3 + AllCapit -> putWord8 4 + Pre ps d -> putWord8 5 >> put ([(map TE.encodeUtf8 p,l) | (p,l) <- ps],d) + Missing f -> putWord8 13 >> put f + Empty -> putWord8 6 + Token t -> putWord8 7 >> put (TE.encodeUtf8 t) + Concat l1 l2 -> putWord8 8 >> put (l1,l2) + Ix i -> putWord8 9 >> put i + Tuple ls -> putWord8 10 >> put ls + Projection l1 l2 -> putWord8 11 >> put (l1,l2) + Argument i -> putWord8 12 >> put i get = do tag <- getWord8 case tag of - 0 -> liftM LFError get - 1 -> return LFBind - 2 -> return LFSpace - 3 -> return LFCapit - 4 -> return LFAllCapit - 5 -> liftM2 (\ps -> LFPre [(map TE.decodeUtf8 p,l) | (p,l) <- ps]) get get - 13 -> liftM LFMissing get - 6 -> return LFEmpty - 7 -> liftM (LFToken . TE.decodeUtf8) get - 8 -> liftM2 LFConcat get get - 9 -> liftM LFInt get - 10 -> liftM LFTuple get - 11 -> liftM2 LFProjection get get - 12 -> liftM LFArgument get + 0 -> liftM Error get + 1 -> return Bind + 2 -> return Space + 3 -> return Capit + 4 -> return AllCapit + 5 -> liftM2 (\ps -> Pre [(map TE.decodeUtf8 p,l) | (p,l) <- ps]) get get + 13 -> liftM Missing get + 6 -> return Empty + 7 -> liftM (Token . TE.decodeUtf8) get + 8 -> liftM2 Concat get get + 9 -> liftM Ix get + 10 -> liftM Tuple get + 11 -> liftM2 Projection get get + 12 -> liftM Argument get _ -> fail "Failed to decode LPGF binary format" abstractName :: LPGF -> CId @@ -168,7 +169,7 @@ linearizeConcreteText concr expr = lin2string $ lin (expr2tree expr) case Map.lookup f (lins concr) of Just t -> eval (map lin as) t -- _ -> error $ printf "Lookup failed for function: %s" (showCId f) - _ -> LFMissing f + _ -> Missing f x -> error $ printf "Cannot lin: %s" (prTree x) -- | Evaluation context is a sequence of terms @@ -177,48 +178,53 @@ type Context = [LinFun] -- | Operational semantics eval :: Context -> LinFun -> LinFun eval cxt t = case t of - LFError err -> error err - LFPre pts df -> LFPre pts' df' + Error err -> error err + Pre pts df -> Pre pts' df' where pts' = [ (strs, eval cxt t) | (strs,t) <- pts] df' = eval cxt df - LFConcat s t -> LFConcat v w + Concat s t -> Concat v w where v = eval cxt s w = eval cxt t - LFTuple ts -> LFTuple vs + Tuple ts -> Tuple vs where vs = map (eval cxt) ts - LFProjection t u -> + Projection t u -> case (eval cxt t, eval cxt u) of - (LFMissing f, _) -> LFMissing f - (_, LFMissing f) -> LFMissing f - (LFTuple vs, LFInt i) -> vs !! (i-1) - (tp@(LFTuple _), LFTuple is) | all isInt is -> foldl (\(LFTuple vs) (LFInt i) -> vs !! (i-1)) tp is - (t',u') -> error $ printf "Incompatible projection:\n- %s ~> %s\n- %s ~> %s" (show t) (show t') (show u) (show u') - LFArgument i -> cxt !! (i-1) + (Missing f, _) -> Missing f + (_, Missing f) -> Missing f + (Tuple vs, Ix i) -> vs !! (i-1) + (tp@(Tuple _), tv@(Tuple _)) | all isIx (flattenTuple tv) -> foldl (\(Tuple vs) (Ix i) -> vs !! (i-1)) tp (flattenTuple tv) + (t',u') -> error $ printf "Incompatible projection:\n- %s\n⇓ %s\n- %s\n⇓ %s" (show t) (show t') (show u) (show u') + Argument i -> cxt !! (i-1) _ -> t +flattenTuple :: LinFun -> [LinFun] +flattenTuple = \case + Tuple vs -> concatMap flattenTuple vs + lf -> [lf] + -- | Turn concrete syntax terms into an actual string lin2string :: LinFun -> Text lin2string l = case l of - LFEmpty -> "" - LFBind -> "" -- when encountered at beginning/end - LFSpace -> "" -- when encountered at beginning/end - LFToken tok -> tok - LFMissing cid -> T.pack $ printf "[%s]" (show cid) - LFTuple [l] -> lin2string l - LFTuple (l:_) -> lin2string l -- unselected table, just choose first option (see e.g. FoodsJpn) - LFPre pts df -> lin2string df -- when encountered at end - LFConcat (LFPre pts df) l2 -> lin2string $ LFConcat l1 l2 + Empty -> "" + Bind -> "" -- when encountered at beginning/end + Space -> "" -- when encountered at beginning/end + Token tok -> tok + Missing cid -> T.pack $ printf "[%s]" (show cid) + Tuple [l] -> lin2string l + Tuple (l:_) -> lin2string l -- unselected table, just choose first option (see e.g. FoodsJpn) + Pre pts df -> lin2string df -- when encountered at end + Concat (Pre pts df) l2 -> lin2string $ Concat l1 l2 where l2' = lin2string l2 matches = [ l | (pfxs, l) <- pts, any (`T.isPrefixOf` l2') pfxs ] l1 = if null matches then df else head matches - LFConcat l1 (LFConcat LFBind l2) -> lin2string l1 `T.append` lin2string l2 - LFConcat l1 (LFConcat LFSpace l2) -> lin2string $ LFConcat l1 l2 - LFConcat LFCapit l2 -> let l = lin2string l2 in T.toUpper (T.take 1 l) `T.append` T.drop 1 l - LFConcat LFAllCapit l2 -> let tks = T.words (lin2string l2) in T.unwords $ T.toUpper (head tks) : tail tks - LFConcat l1 l2 -> T.unwords $ filter (not.T.null) [lin2string l1, lin2string l2] + Concat l1 (Concat Bind l2) -> lin2string l1 `T.append` lin2string l2 + Concat l1 (Concat Space l2) -> lin2string $ Concat l1 l2 + Concat Capit l2 -> let l = lin2string l2 in T.toUpper (T.take 1 l) `T.append` T.drop 1 l + Concat AllCapit l2 -> let tks = T.words (lin2string l2) in T.unwords $ T.toUpper (head tks) : tail tks + Concat l1 l2 -> T.unwords $ filter (not.T.null) [lin2string l1, lin2string l2] x -> T.pack $ printf "[%s]" (show x) -- | List indexing with more verbose error messages @@ -228,19 +234,19 @@ lin2string l = case l of | i > length xs - 1 = error $ printf "!!: index %d too large for list: %s" i (show xs) | otherwise = xs Prelude.!! i -isInt :: LinFun -> Bool -isInt (LFInt _) = True -isInt _ = False +isIx :: LinFun -> Bool +isIx (Ix _) = True +isIx _ = False -- | Helper for building concat trees mkConcat :: [LinFun] -> LinFun -mkConcat [] = LFEmpty +mkConcat [] = Empty mkConcat [x] = x -mkConcat xs = foldl1 LFConcat xs +mkConcat xs = foldl1 Concat xs -- | Helper for unfolding concat trees unConcat :: LinFun -> [LinFun] -unConcat (LFConcat l1 l2) = concatMap unConcat [l1, l2] +unConcat (Concat l1 l2) = concatMap unConcat [l1, l2] unConcat lf = [lf] ------------------------------------------------------------------------------ @@ -268,24 +274,24 @@ instance PP LinFun where pp = pp' 0 where pp' n = \case - LFPre ps d -> do - p "LFPre" + Pre ps d -> do + p "Pre" CMW.tell [ T.replicate (n+1) " " `T.append` T.pack (show p) | p <- ps ] pp' (n+1) d - c@(LFConcat l1 l2) -> do + c@(Concat l1 l2) -> do let ts = unConcat c if any isDeep ts then do - p "LFConcat" + p "Concat" mapM_ (pp' (n+1)) ts else - ps $ "LFConcat " ++ show ts - LFTuple ls | any isDeep ls -> do - p "LFTuple" + ps $ "Concat " ++ show ts + Tuple ls | any isDeep ls -> do + p "Tuple" mapM_ (pp' (n+1)) ls - LFProjection l1 l2 | isDeep l1 || isDeep l2 -> do - p "LFProjection" + Projection l1 l2 | isDeep l1 || isDeep l2 -> do + p "Projection" pp' (n+1) l1 pp' (n+1) l2 t -> ps $ show t @@ -297,8 +303,8 @@ instance PP LinFun where isDeep = not . isTerm isTerm = \case - LFPre _ _ -> False - LFConcat _ _ -> False - LFTuple _ -> False - LFProjection _ _ -> False + Pre _ _ -> False + Concat _ _ -> False + Tuple _ -> False + Projection _ _ -> False _ -> True diff --git a/testsuite/lpgf/unittests/Tables.gf b/testsuite/lpgf/unittests/Tables.gf index fc9459a5f..51c09bc0c 100644 --- a/testsuite/lpgf/unittests/Tables.gf +++ b/testsuite/lpgf/unittests/Tables.gf @@ -1,6 +1,6 @@ abstract Tables = { cat S ; F ; fun - FtoS : F -> S ; + FtoS, FtoS2 : F -> S ; f1, f2, f3, f4, f5, f6 : F ; } diff --git a/testsuite/lpgf/unittests/Tables.treebank b/testsuite/lpgf/unittests/Tables.treebank index 83dac48af..f9b867f90 100644 --- a/testsuite/lpgf/unittests/Tables.treebank +++ b/testsuite/lpgf/unittests/Tables.treebank @@ -15,3 +15,21 @@ TablesCnc: _ Q2 Tables: FtoS f6 TablesCnc: R2 Q3 + +Tables: FtoS2 f1 +TablesCnc: _ _ + +Tables: FtoS2 f2 +TablesCnc: _ Q2 + +Tables: FtoS2 f3 +TablesCnc: R2 Q3 + +Tables: FtoS2 f4 +TablesCnc: _ _ + +Tables: FtoS2 f5 +TablesCnc: _ Q2 + +Tables: FtoS2 f6 +TablesCnc: R2 Q3 diff --git a/testsuite/lpgf/unittests/TablesCnc.gf b/testsuite/lpgf/unittests/TablesCnc.gf index b93c625df..773e9734b 100644 --- a/testsuite/lpgf/unittests/TablesCnc.gf +++ b/testsuite/lpgf/unittests/TablesCnc.gf @@ -16,6 +16,7 @@ concrete TablesCnc of Tables = { f6 = { pr = { r = R2; q = Q3 } } ; FtoS f = tbl ! f.pr ; + FtoS2 f = tbl ! { r = R2 ; q = f.pr.q } ; oper tbl = table { { r = R1 ; q = _ } => "R1 _" ;