diff --git a/lib/resource-1.0/common/Overload.gf b/lib/resource-1.0/common/Overload.gf index 93103877b..395bb7fbd 100644 --- a/lib/resource-1.0/common/Overload.gf +++ b/lib/resource-1.0/common/Overload.gf @@ -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 diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs index 9542331b4..cb8c40e5f 100644 --- a/src/GF/Compile/CheckGrammar.hs +++ b/src/GF/Compile/CheckGrammar.hs @@ -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 diff --git a/src/GF/Source/GrammarToSource.hs b/src/GF/Source/GrammarToSource.hs index 055c79d15..16a68cdb0 100644 --- a/src/GF/Source/GrammarToSource.hs +++ b/src/GF/Source/GrammarToSource.hs @@ -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)]] diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs index 49023bf09..7e525a4b9 100644 --- a/src/GF/Source/SourceToGrammar.hs +++ b/src/GF/Source/SourceToGrammar.hs @@ -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