GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

overload syntax; type printing in CheckGrammar

Browse Source
This commit is contained in:
aarne
2006-11-18 16:54:23 +00:00
parent d5244f46b9
commit 9d3fd3c9cf
4 changed files with 110 additions and 38 deletions
Download Patch File Download Diff File Expand all files Collapse all files

90
lib/resource-1.0/common/Overload.gf
View File

@@ -1,48 +1,92 @@
incomplete resource Overload = open Grammar in {
oper
pred = {
pred : V -> NP -> Cl
= \v,np -> PredVP np (UseV v) ;
pred : V2 -> NP -> NP -> Cl
= \v,np,ob -> PredVP np (ComplV2 v ob) ;
pred : V3 -> NP -> NP -> NP -> Cl
= \v,np,ob,ob2 -> PredVP np (ComplV3 v ob ob2) ;
pred : A -> NP -> Cl
= \a,np -> PredVP np (UseComp (CompAP (PositA a)))
pred = overload {
pred : NP -> V -> Cl
= \v,np -> PredVP np (UseV v) ;
pred : NP -> V2 -> NP -> Cl
= \v,np,ob -> PredVP np (ComplV2 v ob) ;
pred : NP -> V3 -> NP -> NP -> Cl
= \v,np,ob,ob2 ->
PredVP np (ComplV3 v ob ob2) ;
pred : NP -> A -> Cl
= \a,np ->
PredVP np (UseComp (CompAP (PositA a)))
} ;
mod = {
mod = overload {
mod : A -> N -> CN
= \a,n -> AdjCN (PositA a) (UseN n) ;
= \a,n -> AdjCN (PositA a) (UseN n) ;
mod : AP -> N -> CN
= \a,n -> AdjCN a (UseN n) ;
= \a,n -> AdjCN a (UseN n) ;
mod : AP -> CN -> CN
= \a,n -> AdjCN a n ;
mod : AdA -> A -> AP
= \m,a -> AdAP m (PositA a) ;
= \m,a -> AdAP m (PositA a) ;
mod : Quant -> N -> NP
= \q,n -> DetCN (DetSg (SgQuant q) NoOrd) (UseN n) ;
= \q,n -> DetCN (DetSg (SgQuant q) NoOrd)
(UseN n) ;
mod : Quant -> CN -> NP
= \q,n -> DetCN (DetSg (SgQuant q) NoOrd) n ;
= \q,n -> DetCN (DetSg (SgQuant q) NoOrd) n ;
mod : Predet -> N -> NP
= \q,n -> PredetNP q (DetCN (DetPl (PlQuant IndefArt) NoNum NoOrd) (UseN n)) ;
= \q,n -> PredetNP q (DetCN (DetPl
(PlQuant IndefArt) NoNum NoOrd) (UseN n)) ;
mod : Num -> N -> NP
= \nu,n -> DetCN (DetPl (PlQuant IndefArt) nu NoOrd) n
= \nu,n -> DetCN (DetPl (PlQuant
IndefArt) nu NoOrd) (UseN n)
} ;
coord = {
coord = overload {
coord : Conj -> Adv -> Adv -> Adv
= \c,x,y -> ConjAdv and_Conj (BaseAdv x y) ;
= \c,x,y -> ConjAdv c (BaseAdv x y) ;
coord : Conj -> AP -> AP -> AP
= \c,x,y -> ConjAP and_Conj (BaseAP x y) ;
= \c,x,y -> ConjAP c (BaseAP x y) ;
coord : Conj -> NP -> NP -> NP
= \c,x,y -> ConjNP and_Conj (BaseNP x y) ;
= \c,x,y -> ConjNP c (BaseNP x y) ;
coord : Conj -> S -> S -> S
= \c,x,y -> ConjS and_Conj (BaseS x y)
= \c,x,y -> ConjS c (BaseS x y) ;
coord : DConj -> Adv -> Adv -> Adv
= \c,x,y -> DConjAdv c (BaseAdv x y) ;
coord : DConj -> AP -> AP -> AP
= \c,x,y -> DConjAP c (BaseAP x y) ;
coord : DConj -> NP -> NP -> NP
= \c,x,y -> DConjNP c (BaseNP x y) ;
coord : DConj -> S -> S -> S
= \c,x,y -> DConjS c (BaseS x y) ;
coord : Conj -> ListAdv -> Adv
= \c,xy -> ConjAdv c xy ;
coord : Conj -> ListAP -> AP
= \c,xy -> ConjAP c xy ;
coord : Conj -> ListNP -> NP
= \c,xy -> ConjNP c xy ;
coord : Conj -> ListS -> S
= \c,xy -> ConjS c xy ;
coord : DConj -> ListAdv -> Adv
= \c,xy -> DConjAdv c xy ;
coord : DConj -> ListAP -> AP
= \c,xy -> DConjAP c xy ;
coord : DConj -> ListNP -> NP
= \c,xy -> DConjNP c xy ;
coord : DConj -> ListS -> S
= \c,xy -> DConjS c xy
} ;
mkCN = overload {
mkCN : N -> CN
= UseN ;
mkCN : A -> N -> CN
= \a,n -> AdjCN (PositA a) (UseN n) ;
mkCN : AP -> N -> CN
= \a,n -> AdjCN a (UseN n) ;
mkCN : AP -> CN -> CN
= \a,n -> AdjCN a n ;
} ;
mkNP = {
mkNP = overload {
mkNP : NP
= this_NP ;
mkNP : Pron -> NP
= UsePron ;
mkNP : PN -> NP

38
src/GF/Compile/CheckGrammar.hs
View File

@@ -189,7 +189,9 @@ checkResInfo gr mo (c,info) = do
ResOverload tysts -> chIn "overloading" $ do
tysts' <- mapM (uncurry $ flip check) tysts
---- TODO: check uniqueness of arg type lists
return (c,ResOverload [(y,x) | (x,y) <- tysts'])
let tysts2 = [(y,x) | (x,y) <- tysts']
checkUniq $ sort [map snd xs | (x,_) <- tysts2, Ok (xs,_) <- [typeFormCnc x]]
return (c,ResOverload tysts2)
ResParam (Yes (pcs,_)) -> chIn "parameter type" $ do
---- mapM ((mapM (computeLType gr . snd)) . snd) pcs
@@ -204,6 +206,12 @@ checkResInfo gr mo (c,info) = do
chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":")
comp = computeLType gr
checkUniq xss = case xss of
x:y:xs
| x == y -> raise $ "ambiguous for argument list" +++
unwords (map prtType x)
| otherwise -> checkUniq $ y:xs
_ -> return ()
checkCncInfo :: SourceGrammar -> Ident -> (Ident,SourceAbs) ->
@@ -397,7 +405,8 @@ inferLType gr trm = case trm of
then return val
else substituteLType [(z,a')] val
return (App f' a',ty)
_ -> prtFail ("function type expected for"+++ prt f +++"instead of") fty
_ -> raise ("function type expected for"+++
prt f +++"instead of" +++ prtType fty)
S f x -> do
(f', fty) <- infer f
@@ -573,9 +582,9 @@ inferLType gr trm = case trm of
let (tts,tys) = unzip ttys
case lookupOverloadInstance tys typs of
Just (val,fun) -> return (mkApp fun tts, val)
_ -> fail $ "no overload instance of" +++ prt f +++
"for" +++ unwords (map prt_ tys) +++ "among" ++++
unlines [unwords (map prt_ ty) | (ty,_) <- typs]
_ -> raise $ "no overload instance of" +++ prt f +++
"for" +++ unwords (map prtType tys) +++ "among" ++++
unlines [unwords (map prtType ty) | (ty,_) <- typs]
++++ "DEBUG" +++ unwords (map show tys) +++ ";" ++++
unlines (map (show . fst) typs) ----
@@ -599,7 +608,7 @@ checkLType env trm typ0 = do
check c b'
checkReset
return $ (Abs x c', Prod x a b')
_ -> prtFail "product expected instead of" typ
_ -> raise $ "product expected instead of" +++ prtType typ
T _ [] ->
prtFail "found empty table in type" typ
@@ -617,7 +626,7 @@ checkLType env trm typ0 = do
_ -> return () -- happens with variable types
cs' <- mapM (checkCase arg val) cs
return (T (TTyped arg) cs', typ)
_ -> prtFail "table type expected for table instead of" typ
_ -> raise $ "table type expected for table instead of" +++ prtType typ
R r -> case typ of --- why needed? because inference may be too difficult
RecType rr -> do
@@ -672,7 +681,8 @@ checkLType env trm typ0 = do
(arg',val) <- check arg p
checkEq typ t trm
return (S tab' arg', t)
_ -> prtFail "table type expected for applied table instead of" ty'
_ -> raise $ "table type expected for applied table instead of" +++
prtType ty'
, do
(arg',ty) <- infer arg
ty' <- comp ty
@@ -812,7 +822,8 @@ checkEqLType env t u trm = do
checkWarn $ "WARNING: missing lock field" +++ unwords (map prt lo)
return t'
Bad s -> raise (s +++ "type of" +++ prt trm +++
": expected" ++++ prt t' ++++ "inferred" ++++ prt u' ++++ show u')
": expected" ++++ prtType t' ++++
"inferred" ++++ prtType u' ++++ show u')
where
-- t is a subtype of u
@@ -873,6 +884,15 @@ checkEqLType env t u trm = do
sTypes = [typeStr, typeTok, typeString]
comp = computeLType env
-- printing a type with a lock field lock_C as C
prtType :: Type -> String
prtType ty = case ty of
RecType fs -> case filter isLockLabel $ map fst fs of
[lock] -> drop 5 $ prt lock
_ -> prt ty
Prod x a b -> prtType a +++ "->" +++ prtType b
_ -> prt ty
-- | linearization types and defaults
linTypeOfType :: SourceGrammar -> Ident -> Type -> Check (Context,Type)
linTypeOfType cnc m typ = do

3
src/GF/Source/GrammarToSource.hs
View File

@@ -96,7 +96,8 @@ trAnyDef (i,info) = let i' = tri i in case info of
ResOverload tysts ->
[P.DefOper [P.DDef [mkName i'] (
P.ERecord [P.LDFull [i'] (trt ty) (trt fu) | (ty,fu) <- tysts])]]
P.EApp (P.EIdent $ identC "overload")
(P.ERecord [P.LDFull [i'] (trt ty) (trt fu) | (ty,fu) <- tysts]))]]
CncCat (Yes ty) Nope _ ->
[P.DefLincat [P.PrintDef [mkName i'] (trt ty)]]

17
src/GF/Source/SourceToGrammar.hs
View File

@@ -299,7 +299,7 @@ transResDef x = case x of
(p,pars) <- pardefs', (f,co) <- pars]
DefOper defs -> do
defs' <- liftM concat $ mapM getDefs defs
returnl [mkOverload (f, G.ResOper pt pe) | (f,(pt,pe)) <- defs']
returnl $ concatMap mkOverload [(f, G.ResOper pt pe) | (f,(pt,pe)) <- defs']
DefLintype defs -> do
defs' <- liftM concat $ mapM getDefs defs
@@ -309,10 +309,17 @@ transResDef x = case x of
_ -> Bad $ "illegal definition form in resource" +++ printTree x
where
mkOverload (c,j) = case j of
G.ResOper Nope (Yes (G.R fs@(_:_:_))) | isOverloading c fs ->
(c,G.ResOverload [(ty,fu) | (_,(Just ty,fu)) <- fs])
_ -> (c,j)
isOverloading c fs = all (== GP.prt c) (map (GP.prt . fst) fs)
G.ResOper _ (Yes (G.App keyw (G.R fs@(_:_:_)))) |
isOverloading keyw c fs ->
[(c,G.ResOverload [(ty,fu) | (_,(Just ty,fu)) <- fs])]
-- to enable separare type signature --- not type-checked
G.ResOper (Yes (G.App keyw (G.RecType fs@(_:_:_)))) _ |
isOverloading keyw c fs -> []
_ -> [(c,j)]
isOverloading keyw c fs =
GP.prt keyw == "overload" && -- overload is a "soft keyword"
all (== GP.prt c) (map (GP.prt . fst) fs)
transParDef :: ParDef -> Err (Ident, [G.Param])
transParDef x = case x of