mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-14 07:19:31 -06:00
Nonlinear patterns in concrete syntax are now detected and reported as errors
Before, they were silently converted to linear patterns. Nonlinear patterns in MorphoCat.gf, ParadigmsGre.gf and ParadigmsFin.gf have been make linear by renaming pattern variables.
This commit is contained in:
hallgren
@@ -236,7 +236,7 @@ oper
|
||||
mkAdj2Reg : Str -> Str -> Adj = \petit,petita ->
|
||||
case <petit,petita> of {
|
||||
<_, _ + ("b"|"c"|"d"|"e"|"f"|"g"|"h"|"i"|"j"|"k"|"l"|"m"|"n"|"o"|"p"|"q"|"r"|"s"|"t"|"u"|"v"|"x"|"y"|"z")> => adjFidel petit ; --feminine doesn't end in "a"
|
||||
<p@(_ + ("t"|"l"|"ç")), p+"a"> => adjPrim petit ; --1) petit~petita 2) ridícul~ridícula, dolç~dolça
|
||||
<p@(_ + ("t"|"l"|"ç")), p2+"a"> => adjPrim petit ; --1) petit~petita 2) ridícul~ridícula, dolç~dolça -- was nonlinear
|
||||
<_ + "ig", _> => adjIg petit petita ; --lleig~letja
|
||||
<_, _+ "na"> => adjVn petit ; --pla~plana
|
||||
<_, _ + ("à"|"é"|"è"|"í"|"ó"|"ò"|"ú") + _> => adjBlau petit petita ; --diari~diària
|
||||
|
||||
@@ -522,9 +522,9 @@ mkVS = overload {
|
||||
dSilakka ukko ukon ukkoja ; -- auto,auton
|
||||
<_ + "mpi", _ + ("emman" | "emmän")> => dSuurempi ukko ;
|
||||
<_ + "in", _ + ("imman" | "immän")> => dSuurin ukko ;
|
||||
<terv + "e", terv + "een"> =>
|
||||
<terv + "e", terv2 + "een"> => -- was nonlinear
|
||||
dRae ukko ukon ;
|
||||
<taiv + ("as" | "äs"), taiv + ("aan" | "ään")> =>
|
||||
<taiv + ("as" | "äs"), taiv2 + ("aan" | "ään")> => -- was nonlinear
|
||||
dRae ukko ukon ;
|
||||
<nukk + "e", nuk + "een"> => dRae ukko ukon ;
|
||||
<arp + "i", arv + "en"> => dArpi ukko ukon ;
|
||||
|
||||
@@ -42,14 +42,15 @@ oper
|
||||
|
||||
mkNending : Str -> Str -> Gender -> N = \x,n,g ->
|
||||
case <x,n> of {
|
||||
<c + "ος", c + "ων"> => mkNoun_anthropos x n g ;
|
||||
<c + "η", c + "εις"> => mkNoun_kivernisi x n g ;
|
||||
<c + "ης", c + "ηδες"> => mkNoun_fournaris x n g ;
|
||||
<c + "ας", c + "ων"> => mkNoun_filakas x n g ;
|
||||
<c + "ο", c + "ων"> => mkNoun_prosopo x n g ;
|
||||
<c + ("ώς" | "ός" | "ως" ) , c + ("ος"|"ός" ) > => mkNoun_fws x n g ;
|
||||
<c + ("μα" | "ιμο" ), c + "ατα"> => mkNoun_provlima x n g ;
|
||||
<c + "ος", c + "η"> => mkNoun_megethos x n g
|
||||
-- all of these were nonlinear
|
||||
<c + "ος", c2 + "ων"> => mkNoun_anthropos x n g ;
|
||||
<c + "η", c2 + "εις"> => mkNoun_kivernisi x n g ;
|
||||
<c + "ης", c2 + "ηδες"> => mkNoun_fournaris x n g ;
|
||||
<c + "ας", c2 + "ων"> => mkNoun_filakas x n g ;
|
||||
<c + "ο", c2 + "ων"> => mkNoun_prosopo x n g ;
|
||||
<c + ("ώς" | "ός" | "ως" ) , c2 + ("ος"|"ός" ) > => mkNoun_fws x n g ;
|
||||
<c + ("μα" | "ιμο" ), c2 + "ατα"> => mkNoun_provlima x n g ;
|
||||
<c + "ος", c2 + "η"> => mkNoun_megethos x n g
|
||||
} ** {lock_N = <>} ;
|
||||
|
||||
|
||||
@@ -128,9 +129,9 @@ oper
|
||||
|
||||
mkA1 : Str -> Str -> A = \x,n ->
|
||||
case <x,n> of {
|
||||
<c + "ης", c + "ες"> => mkAdjective4 x n ;
|
||||
<c + "ων", c + "όντων"> => mkAdjective3 x n ;
|
||||
<c + "ύς", c + "έως"> => mkAdjectiveIr x n
|
||||
<c + "ης", c2 + "ες"> => mkAdjective4 x n ; -- was nonlinear
|
||||
<c + "ων", c2 + "όντων"> => mkAdjective3 x n ; -- was nonlinear
|
||||
<c + "ύς", c2 + "έως"> => mkAdjectiveIr x n -- was nonlinear
|
||||
} ** {lock_A = <>} ;
|
||||
|
||||
|
||||
|
||||
@@ -39,7 +39,7 @@ import GF.Grammar.Printer
|
||||
import GF.Data.Operations
|
||||
|
||||
import Control.Monad
|
||||
import Data.List (nub)
|
||||
import Data.List (nub,(\\))
|
||||
import Text.PrettyPrint
|
||||
|
||||
-- | this gives top-level access to renaming term input in the cc command
|
||||
@@ -235,76 +235,80 @@ renameTerm env vars = ren vars where
|
||||
|
||||
-- | vars not needed in env, since patterns always overshadow old vars
|
||||
renamePattern :: Status -> Patt -> Check (Patt,[Ident])
|
||||
renamePattern env patt = case patt of
|
||||
renamePattern env patt =
|
||||
do r@(p',vs) <- renp patt
|
||||
let dupl = vs \\ nub vs
|
||||
unless (null dupl) $ checkError (hang (text "[C.4.13] Pattern is not linear:") 4
|
||||
(ppPatt Unqualified 0 patt))
|
||||
return r
|
||||
where
|
||||
renp patt = case patt of
|
||||
PMacro c -> do
|
||||
c' <- renid $ Vr c
|
||||
case c' of
|
||||
Q d -> renp $ PM d
|
||||
_ -> checkError (text "unresolved pattern" <+> ppPatt Unqualified 0 patt)
|
||||
|
||||
PMacro c -> do
|
||||
c' <- renid $ Vr c
|
||||
case c' of
|
||||
Q d -> renp $ PM d
|
||||
_ -> checkError (text "unresolved pattern" <+> ppPatt Unqualified 0 patt)
|
||||
PC c ps -> do
|
||||
c' <- renid $ Cn c
|
||||
case c' of
|
||||
QC c -> do psvss <- mapM renp ps
|
||||
let (ps,vs) = unzip psvss
|
||||
return (PP c ps, concat vs)
|
||||
Q _ -> checkError (text "data constructor expected but" <+> ppTerm Qualified 0 c' <+> text "is found instead")
|
||||
_ -> checkError (text "unresolved data constructor" <+> ppTerm Qualified 0 c')
|
||||
|
||||
PC c ps -> do
|
||||
c' <- renid $ Cn c
|
||||
case c' of
|
||||
QC c -> do psvss <- mapM renp ps
|
||||
let (ps,vs) = unzip psvss
|
||||
return (PP c ps, concat vs)
|
||||
Q _ -> checkError (text "data constructor expected but" <+> ppTerm Qualified 0 c' <+> text "is found instead")
|
||||
_ -> checkError (text "unresolved data constructor" <+> ppTerm Qualified 0 c')
|
||||
PP c ps -> do
|
||||
(QC c') <- renid (QC c)
|
||||
psvss <- mapM renp ps
|
||||
let (ps',vs) = unzip psvss
|
||||
return (PP c' ps', concat vs)
|
||||
|
||||
PP c ps -> do
|
||||
(QC c') <- renid (QC c)
|
||||
psvss <- mapM renp ps
|
||||
let (ps',vs) = unzip psvss
|
||||
return (PP c' ps', concat vs)
|
||||
PM c -> do
|
||||
x <- renid (Q c)
|
||||
c' <- case x of
|
||||
(Q c') -> return c'
|
||||
_ -> checkError (text "not a pattern macro" <+> ppPatt Qualified 0 patt)
|
||||
return (PM c', [])
|
||||
|
||||
PM c -> do
|
||||
x <- renid (Q c)
|
||||
c' <- case x of
|
||||
(Q c') -> return c'
|
||||
_ -> checkError (text "not a pattern macro" <+> ppPatt Qualified 0 patt)
|
||||
return (PM c', [])
|
||||
PV x -> checks [ renid' (Vr x) >>= \t' -> case t' of
|
||||
QC c -> return (PP c [],[])
|
||||
_ -> checkError (text "not a constructor")
|
||||
, return (patt, [x])
|
||||
]
|
||||
|
||||
PV x -> checks [ renid' (Vr x) >>= \t' -> case t' of
|
||||
QC c -> return (PP c [],[])
|
||||
_ -> checkError (text "not a constructor")
|
||||
, return (patt, [x])
|
||||
]
|
||||
PR r -> do
|
||||
let (ls,ps) = unzip r
|
||||
psvss <- mapM renp ps
|
||||
let (ps',vs') = unzip psvss
|
||||
return (PR (zip ls ps'), concat vs')
|
||||
|
||||
PR r -> do
|
||||
let (ls,ps) = unzip r
|
||||
psvss <- mapM renp ps
|
||||
let (ps',vs') = unzip psvss
|
||||
return (PR (zip ls ps'), concat vs')
|
||||
PAlt p q -> do
|
||||
(p',vs) <- renp p
|
||||
(q',ws) <- renp q
|
||||
return (PAlt p' q', vs ++ ws)
|
||||
|
||||
PAlt p q -> do
|
||||
(p',vs) <- renp p
|
||||
(q',ws) <- renp q
|
||||
return (PAlt p' q', vs ++ ws)
|
||||
PSeq p q -> do
|
||||
(p',vs) <- renp p
|
||||
(q',ws) <- renp q
|
||||
return (PSeq p' q', vs ++ ws)
|
||||
|
||||
PSeq p q -> do
|
||||
(p',vs) <- renp p
|
||||
(q',ws) <- renp q
|
||||
return (PSeq p' q', vs ++ ws)
|
||||
PRep p -> do
|
||||
(p',vs) <- renp p
|
||||
return (PRep p', vs)
|
||||
|
||||
PRep p -> do
|
||||
(p',vs) <- renp p
|
||||
return (PRep p', vs)
|
||||
PNeg p -> do
|
||||
(p',vs) <- renp p
|
||||
return (PNeg p', vs)
|
||||
|
||||
PNeg p -> do
|
||||
(p',vs) <- renp p
|
||||
return (PNeg p', vs)
|
||||
PAs x p -> do
|
||||
(p',vs) <- renp p
|
||||
return (PAs x p', x:vs)
|
||||
|
||||
PAs x p -> do
|
||||
(p',vs) <- renp p
|
||||
return (PAs x p', x:vs)
|
||||
_ -> return (patt,[])
|
||||
|
||||
_ -> return (patt,[])
|
||||
|
||||
where
|
||||
renp = renamePattern env
|
||||
renid = renameIdentTerm env
|
||||
renid' = renameIdentTerm' env
|
||||
renid = renameIdentTerm env
|
||||
renid' = renameIdentTerm' env
|
||||
|
||||
renameContext :: Status -> Context -> Check Context
|
||||
renameContext b = renc [] where
|
||||
|
||||
Reference in New Issue
Block a user