overload syntax; type printing in CheckGrammar

lib/resource-1.0/common/Overload.gf

@@ -1,48 +1,92 @@
 incomplete resource Overload = open Grammar in {
 
   oper
-    pred = {
+
-      pred : V  -> NP -> Cl
+    pred = overload {
-        = \v,np -> PredVP np (UseV v) ;
+      pred : NP -> V -> Cl
-      pred : V2 -> NP -> NP -> Cl
+                                       = \v,np -> PredVP np (UseV v) ;
-        = \v,np,ob -> PredVP np (ComplV2 v ob) ;
+      pred : NP -> V2 -> NP -> Cl
-      pred : V3 -> NP -> NP -> NP -> Cl 
+                                       = \v,np,ob -> PredVP np (ComplV2 v ob) ;
-        = \v,np,ob,ob2 -> PredVP np (ComplV3 v ob ob2) ;
+      pred : NP -> V3 -> NP -> NP -> Cl 
-      pred : A  -> NP -> Cl 
+                                       = \v,np,ob,ob2 -> 
-        = \a,np -> PredVP np (UseComp (CompAP (PositA a)))
+                                          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

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 +++ 
+       _ -> raise $ "no overload instance of" +++ prt f +++ 
-         "for" +++ unwords (map prt_ tys) +++ "among" ++++ 
+         "for" +++ unwords (map prtType tys) +++ "among" ++++ 
-         unlines [unwords (map prt_ ty) | (ty,_) <- typs]
+         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

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)]] 

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 -> 
+     G.ResOper _ (Yes (G.App keyw (G.R fs@(_:_:_)))) | 
-       (c,G.ResOverload [(ty,fu) | (_,(Just ty,fu)) <- fs])
+                                          isOverloading keyw c fs -> 
-     _ -> (c,j)
+       [(c,G.ResOverload [(ty,fu) | (_,(Just ty,fu)) <- fs])]
-   isOverloading c fs = all (== GP.prt c) (map (GP.prt . fst) 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