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

Remove LF prefix from constructors. Pass all unit tests and Foods again, but improvements/cleanup still necessary.

Browse Source
This commit is contained in:
John J. Camilleri
2021-03-03 09:19:52 +01:00
parent 33e0e98aec
commit 4c09e4a340
5 changed files with 208 additions and 139 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -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

186
src/runtime/haskell/LPGF.hs
View File

@@ -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

2
testsuite/lpgf/unittests/Tables.gf
View File

@@ -1,6 +1,6 @@
abstract Tables = {
cat S ; F ;
fun
FtoS : F -> S ;
FtoS, FtoS2 : F -> S ;
f1, f2, f3, f4, f5, f6 : F ;
}

18
testsuite/lpgf/unittests/Tables.treebank
View File

@@ -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

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

@@ -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 _" ;