From bea6aa1d2d10669d62c1c5125dedac4cac0f8cfa Mon Sep 17 00:00:00 2001 From: Thomas Hallgren Date: Thu, 25 Apr 2019 17:02:42 +0200 Subject: GF.Compile.CheckGrammar: discard bad 'lincat C = …' with a warning e.g. if C is a fun and not a cat in the abstract syntax. Discarding bad lincats prevents GF from generating malformed PGFs that are rejected by the C run-time system. I also added code to reject bad lincats with an error, but I left it commented out since it seems a bit pedantic compared to GF's otherwise rather sloppy grammar checking. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/compiler/GF/Compile/CheckGrammar.hs | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) (limited to 'src/compiler') diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs index 1348d8e41..5d6922704 100644 --- a/src/compiler/GF/Compile/CheckGrammar.hs +++ b/src/compiler/GF/Compile/CheckGrammar.hs @@ -147,11 +147,17 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc return $ updateTree (c,CncFun (Just linty) d mn mf) js _ -> do checkWarn ("function" <+> c <+> "is not in abstract") return js - CncCat _ _ _ _ _ -> case lookupOrigInfo gr (am,c) of - Ok _ -> return $ updateTree i js - _ -> do checkWarn ("category" <+> c <+> "is not in abstract") - return js - _ -> return $ updateTree i js + CncCat {} -> + case lookupOrigInfo gr (am,c) of + Ok (_,AbsCat _) -> return $ updateTree i js + {- -- This might be too pedantic: + Ok (_,AbsFun {}) -> + checkError ("lincat:"<+>c<+>"is a fun, not a cat") + -} + _ -> do checkWarn ("category" <+> c <+> "is not in abstract") + return js + + _ -> return $ updateTree i js -- | General Principle: only Just-values are checked. -- cgit v1.2.3 From 86066d4b12d61e999740bf6a3a09b6547697ee13 Mon Sep 17 00:00:00 2001 From: Thomas Hallgren Date: Wed, 15 May 2019 12:05:38 +0200 Subject: Eliminate the dependency on time-compat It was only needed for compatibility with directory<1.2, but directory>=1.2 has been shipped with ghc since ghc-7.6. Note: time-compat-1.9.* (the current version) is a completely different package, that does not provide the needed function toUTCTime, which was provided in time-compat-0.1.*. --- gf.cabal | 2 +- src/compiler/GF/System/Directory.hs | 4 ++-- src/server/Cache.hs | 4 ++-- 3 files changed, 5 insertions(+), 5 deletions(-) (limited to 'src/compiler') diff --git a/gf.cabal b/gf.cabal index f350b2ca1..ec889a335 100644 --- a/gf.cabal +++ b/gf.cabal @@ -142,7 +142,7 @@ Library ---- GF compiler as a library: - build-depends: filepath, directory, time, time-compat, + build-depends: filepath, directory>=1.2, time, process, haskeline, parallel>=3, json hs-source-dirs: src/compiler diff --git a/src/compiler/GF/System/Directory.hs b/src/compiler/GF/System/Directory.hs index 898646063..be91e758e 100644 --- a/src/compiler/GF/System/Directory.hs +++ b/src/compiler/GF/System/Directory.hs @@ -8,13 +8,13 @@ import System.Directory as D doesDirectoryExist,doesFileExist,getModificationTime, getCurrentDirectory,getDirectoryContents,getPermissions, removeFile,renameFile) -import Data.Time.Compat +--import Data.Time.Compat canonicalizePath path = liftIO $ D.canonicalizePath path createDirectoryIfMissing b = liftIO . D.createDirectoryIfMissing b doesDirectoryExist path = liftIO $ D.doesDirectoryExist path doesFileExist path = liftIO $ D.doesFileExist path -getModificationTime path = liftIO $ fmap toUTCTime (D.getModificationTime path) +getModificationTime path = liftIO $ {-fmap toUTCTime-} (D.getModificationTime path) getDirectoryContents path = liftIO $ D.getDirectoryContents path getCurrentDirectory :: MonadIO io => io FilePath diff --git a/src/server/Cache.hs b/src/server/Cache.hs index d05ee2557..dc1eebdba 100644 --- a/src/server/Cache.hs +++ b/src/server/Cache.hs @@ -9,7 +9,7 @@ import Data.Maybe(mapMaybe) import System.Directory (getModificationTime) import System.Mem(performGC) import Data.Time (UTCTime,getCurrentTime,diffUTCTime) -import Data.Time.Compat (toUTCTime) +--import Data.Time.Compat (toUTCTime) data Cache a = Cache { cacheLoad :: FilePath -> IO a, @@ -63,7 +63,7 @@ readCache' c file = Nothing -> do v <- newMVar Nothing return (Map.insert file v objs, v) -- Check time stamp, and reload if different than the cache entry - readObject m = do t' <- toUTCTime `fmap` getModificationTime file + readObject m = do t' <- {-toUTCTime `fmap`-} getModificationTime file now <- getCurrentTime x' <- case m of Just (t,_,x) | t' == t -> return x -- cgit v1.2.3 From b7249adf63acf717210af2fa2e552bd50473b960 Mon Sep 17 00:00:00 2001 From: Aarne Ranta Date: Mon, 20 May 2019 15:58:47 +0200 Subject: reordered error message for 'no overload'; might be even better to show complete types --- src/compiler/GF/Compile/TypeCheck/RConcrete.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) (limited to 'src/compiler') diff --git a/src/compiler/GF/Compile/TypeCheck/RConcrete.hs b/src/compiler/GF/Compile/TypeCheck/RConcrete.hs index 88e324ff3..134e71559 100644 --- a/src/compiler/GF/Compile/TypeCheck/RConcrete.hs +++ b/src/compiler/GF/Compile/TypeCheck/RConcrete.hs @@ -360,12 +360,13 @@ getOverload gr g mt ot = case appForm ot of nest 2 (showTypes pre) return (mkApp fun tts, val) ([],[]) -> do - checkError $ "no overload instance of" <+> ppTerm Unqualified 0 f $$ - "for" $$ + checkError $ "no overload instance of" <+> ppTerm Qualified 0 f $$ + maybe empty (\x -> "with value type" <+> ppType x) mt $$ + "for argument list" $$ nest 2 stysError $$ - "among" $$ - nest 2 (vcat stypsError) $$ - maybe empty (\x -> "with value type" <+> ppType x) mt + "among alternatives" $$ + nest 2 (vcat stypsError) + (vfs1,vfs2) -> case (noProds vfs1,noProds vfs2) of ([(val,fun)],_) -> do -- cgit v1.2.3