if the lincat is empty record the linearizations are derived automatically

1 files changed, 25 insertions, 8 deletions

diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs
index 47434d74e..eaa4523e4 100644
--- a/src/GF/Compile/CheckGrammar.hs
+++ b/src/GF/Compile/CheckGrammar.hs
@@ -75,7 +75,7 @@ checkModule ms (name,mo) = checkIn ("checking module" +++ prt name) $ do
       MTConcrete a -> do
         checkErr $ topoSortOpers $ allOperDependencies name js
         abs <- checkErr $ lookupModule gr a
-        js1 <- checkCompleteGrammar abs mo
+        js1 <- checkCompleteGrammar gr abs mo
         mapsCheckTree (checkCncInfo gr name mo (a,abs)) js1
 
       MTInterface -> mapsCheckTree (checkResInfo gr name mo) js
@@ -172,8 +172,8 @@ checkAbsInfo st m mo (c,info) = do
      R fs -> mkApp t (map (snd . snd) fs)
      _ -> mkApp t [a]
 
-checkCompleteGrammar :: SourceModInfo -> SourceModInfo -> Check (BinTree Ident Info)
-checkCompleteGrammar abs cnc = do
+checkCompleteGrammar :: SourceGrammar -> SourceModInfo -> SourceModInfo -> Check (BinTree Ident Info)
+checkCompleteGrammar gr abs cnc = do
   let jsa = jments abs
   let fsa = tree2list jsa
   let jsc = jments cnc
@@ -194,11 +194,28 @@ checkCompleteGrammar abs cnc = do
      CncCat _ _ _ -> True
      _ -> False
    checkOne js i@(c,info) = case info of
-     AbsFun (Just _) _ -> case lookupIdent c js of
-       Ok _ -> return js
-       _ -> do
-         checkWarn $ "WARNING: no linearization of" +++ prt c
-         return js
+     AbsFun (Just ty) _ -> do mb_def <- checkErr $ do
+                                          (cxt,(_,i),_) <- typeForm ty
+                                          info <- lookupIdent i js
+                                          info <- case info of
+                                                    (AnyInd _ m) -> do (m,info) <- lookupOrigInfo gr m i
+                                                                       return info
+                                                    _            -> return info
+                                          case info of
+                                            CncCat (Just (RecType [])) _ _ -> return (Just (foldr (\_ -> Abs identW) (R []) cxt))
+                                            _                              -> return Nothing
+                              case lookupIdent c js of
+                                Ok (CncFun _   (Just _) _ ) -> return js
+                                Ok (CncFun cty Nothing  pn) ->
+                                  case mb_def of
+                                    Just def -> return $ updateTree (c,CncFun cty (Just def) pn) js
+                                    Nothing  -> do checkWarn $ "WARNING: no linearization of" +++ prt c
+                                                   return js
+                                _ -> do
+                                  case mb_def of
+                                    Just def -> return $ updateTree (c,CncFun Nothing (Just def) Nothing) js
+                                    Nothing  -> do checkWarn $ "WARNING: no linearization of" +++ prt c
+                                                   return js
      AbsCat (Just _) _ -> case lookupIdent c js of
        Ok (AnyInd _ _) -> return js
        Ok (CncCat (Just _) _ _) -> return js