Warnings infrastructure (for #297)

AshleyYakeley · Nov 29, 2024 · ec724a5 · ec724a5
1 parent dd67eb7
commit ec724a5
Show file tree

Hide file tree

Showing 22 changed files with 162 additions and 110 deletions.
diff --git a/Pinafore/pinafore-app/app/main/Main.hs b/Pinafore/pinafore-app/app/main/Main.hs
@@ -18,7 +18,7 @@ main =
             sqliteQDumpTable pinaforedir
         RunFileOption ropts fNoRun fscript -> do
             copts <- getModuleOptions ropts
-            runFiles copts fNoRun [fscript]
+            runFiles (roSloppy ropts) copts fNoRun [fscript]
         RunInteractiveOption ropts -> do
             copts <- getModuleOptions ropts
-            runInteractive copts
+            runInteractive (roSloppy ropts) copts
diff --git a/Pinafore/pinafore-app/app/main/Options.hs b/Pinafore/pinafore-app/app/main/Options.hs
@@ -49,7 +49,7 @@ optNoRun :: Parser Bool
 optNoRun = switch $ long "no-run" <> short 'n'
 
 optRunOptions :: Parser RunOptions
-optRunOptions = MkRunOptions <$> optIncludes <*> optDataPath
+optRunOptions = MkRunOptions <$> optIncludes <*> optDataPath <*> switch (long "sloppy")
 
 assignReader :: ReadM (Text, Text)
 assignReader =

diff --git a/Pinafore/pinafore-app/app/main/Run.hs b/Pinafore/pinafore-app/app/main/Run.hs
@@ -7,22 +7,24 @@ import Changes.Core
 import Pinafore.Main
 import Shapes
 
-runFiles :: Foldable t => ModuleOptions -> Bool -> t (FilePath, [String], [(Text, Text)]) -> IO ()
-runFiles modopts fNoRun scripts =
+runFiles :: Foldable t => Bool -> ModuleOptions -> Bool -> t (FilePath, [String], [(Text, Text)]) -> IO ()
+runFiles ibSloppy modopts fNoRun scripts =
     runWithOptions defaultExecutionOptions $
     runLifecycle $
     runView $
     for_ scripts $ \(fpath, args, implArgs) -> do
-        let ?library = standardLibraryContext modopts
+        let ibLoadModule = standardLoadModule modopts
+        let ?behaviour = MkInterpretBehaviour {..}
         action <- qInterpretScriptFile fpath args implArgs
         if fNoRun
             then return ()
             else action
 
-runInteractive :: ModuleOptions -> IO ()
-runInteractive modopts =
+runInteractive :: Bool -> ModuleOptions -> IO ()
+runInteractive ibSloppy modopts =
     runWithOptions defaultExecutionOptions $
     runLifecycle $
     runView $ do
-        let ?library = standardLibraryContext modopts
+        let ibLoadModule = standardLoadModule modopts
+        let ?behaviour = MkInterpretBehaviour {..}
         qInteract
diff --git a/Pinafore/pinafore-app/app/main/Test.hs b/Pinafore/pinafore-app/app/main/Test.hs
@@ -27,66 +27,80 @@ testOptionParsing =
         , testTree
               "script"
               [ testOptions ["scriptname"] $
-                SuccessResult $ RunFileOption (MkRunOptions [] Nothing) False ("scriptname", [], [])
+                SuccessResult $ RunFileOption (MkRunOptions [] Nothing False) False ("scriptname", [], [])
               , testOptions ["scriptname", "a"] $
-                SuccessResult $ RunFileOption (MkRunOptions [] Nothing) False ("scriptname", ["a"], [])
+                SuccessResult $ RunFileOption (MkRunOptions [] Nothing False) False ("scriptname", ["a"], [])
               , testOptions ["scriptname", "-x"] $
-                SuccessResult $ RunFileOption (MkRunOptions [] Nothing) False ("scriptname", ["-x"], [])
+                SuccessResult $ RunFileOption (MkRunOptions [] Nothing False) False ("scriptname", ["-x"], [])
               , testOptions ["scriptname", "--opt"] $
-                SuccessResult $ RunFileOption (MkRunOptions [] Nothing) False ("scriptname", ["--opt"], [])
+                SuccessResult $ RunFileOption (MkRunOptions [] Nothing False) False ("scriptname", ["--opt"], [])
               , testOptions ["scriptname", "-n"] $
-                SuccessResult $ RunFileOption (MkRunOptions [] Nothing) False ("scriptname", ["-n"], [])
+                SuccessResult $ RunFileOption (MkRunOptions [] Nothing False) False ("scriptname", ["-n"], [])
               , testOptions ["scriptname", "-v"] $
-                SuccessResult $ RunFileOption (MkRunOptions [] Nothing) False ("scriptname", ["-v"], [])
+                SuccessResult $ RunFileOption (MkRunOptions [] Nothing False) False ("scriptname", ["-v"], [])
               , testOptions ["scriptname", "--data", "dpath"] $
-                SuccessResult $ RunFileOption (MkRunOptions [] Nothing) False ("scriptname", ["--data", "dpath"], [])
+                SuccessResult $
+                RunFileOption (MkRunOptions [] Nothing False) False ("scriptname", ["--data", "dpath"], [])
               , testOptions ["-n", "scriptname"] $
-                SuccessResult $ RunFileOption (MkRunOptions [] Nothing) True ("scriptname", [], [])
+                SuccessResult $ RunFileOption (MkRunOptions [] Nothing False) True ("scriptname", [], [])
+              , testOptions ["--sloppy", "scriptname"] $
+                SuccessResult $ RunFileOption (MkRunOptions [] Nothing True) False ("scriptname", [], [])
               , testOptions ["--imply", "pqr=vv", "scriptname"] $
-                SuccessResult $ RunFileOption (MkRunOptions [] Nothing) False ("scriptname", [], [("pqr", "vv")])
+                SuccessResult $ RunFileOption (MkRunOptions [] Nothing False) False ("scriptname", [], [("pqr", "vv")])
               , testOptions ["--imply", "a=1", "--imply", "b=2", "--imply", "c=3", "scriptname"] $
                 SuccessResult $
-                RunFileOption (MkRunOptions [] Nothing) False ("scriptname", [], [("a", "1"), ("b", "2"), ("c", "3")])
+                RunFileOption
+                    (MkRunOptions [] Nothing False)
+                    False
+                    ("scriptname", [], [("a", "1"), ("b", "2"), ("c", "3")])
               , testOptions ["-n", "scriptname", "-n"] $
-                SuccessResult $ RunFileOption (MkRunOptions [] Nothing) True ("scriptname", ["-n"], [])
+                SuccessResult $ RunFileOption (MkRunOptions [] Nothing False) True ("scriptname", ["-n"], [])
               , testOptions ["-I", "incpath", "scriptname"] $
-                SuccessResult $ RunFileOption (MkRunOptions ["incpath"] Nothing) False ("scriptname", [], [])
+                SuccessResult $ RunFileOption (MkRunOptions ["incpath"] Nothing False) False ("scriptname", [], [])
               , testOptions ["-I", "path1", "-I", "path2", "scriptname"] $
-                SuccessResult $ RunFileOption (MkRunOptions ["path1", "path2"] Nothing) False ("scriptname", [], [])
+                SuccessResult $
+                RunFileOption (MkRunOptions ["path1", "path2"] Nothing False) False ("scriptname", [], [])
               , testOptions ["--include", "incpath", "scriptname"] $
-                SuccessResult $ RunFileOption (MkRunOptions ["incpath"] Nothing) False ("scriptname", [], [])
+                SuccessResult $ RunFileOption (MkRunOptions ["incpath"] Nothing False) False ("scriptname", [], [])
               , testOptions ["--include", "path1", "--include", "path2", "scriptname"] $
-                SuccessResult $ RunFileOption (MkRunOptions ["path1", "path2"] Nothing) False ("scriptname", [], [])
+                SuccessResult $
+                RunFileOption (MkRunOptions ["path1", "path2"] Nothing False) False ("scriptname", [], [])
               , testOptions ["--data", "dpath", "scriptname"] $
-                SuccessResult $ RunFileOption (MkRunOptions [] (Just "dpath")) False ("scriptname", [], [])
+                SuccessResult $ RunFileOption (MkRunOptions [] (Just "dpath") False) False ("scriptname", [], [])
               , testOptions ["--data", "dpath", "scriptname", "arg1"] $
-                SuccessResult $ RunFileOption (MkRunOptions [] (Just "dpath")) False ("scriptname", ["arg1"], [])
+                SuccessResult $ RunFileOption (MkRunOptions [] (Just "dpath") False) False ("scriptname", ["arg1"], [])
               , testOptions ["--data", "dpath", "scriptname", "arg1", "arg2"] $
                 SuccessResult $
-                RunFileOption (MkRunOptions [] (Just "dpath")) False ("scriptname", ["arg1", "arg2"], [])
+                RunFileOption (MkRunOptions [] (Just "dpath") False) False ("scriptname", ["arg1", "arg2"], [])
               , testOptions ["-n", "--data", "dpath", "scriptname", "arg1", "arg2"] $
-                SuccessResult $ RunFileOption (MkRunOptions [] (Just "dpath")) True ("scriptname", ["arg1", "arg2"], [])
+                SuccessResult $
+                RunFileOption (MkRunOptions [] (Just "dpath") False) True ("scriptname", ["arg1", "arg2"], [])
+              , testOptions ["-n", "--sloppy", "--data", "dpath", "scriptname", "arg1", "arg2"] $
+                SuccessResult $
+                RunFileOption (MkRunOptions [] (Just "dpath") True) True ("scriptname", ["arg1", "arg2"], [])
               ]
         , testTree
               "interactive"
-              [ testOptions ["-i"] $ SuccessResult $ RunInteractiveOption $ MkRunOptions [] Nothing
+              [ testOptions ["-i"] $ SuccessResult $ RunInteractiveOption $ MkRunOptions [] Nothing False
               , testOptions ["-i", "--data", "dpath"] $
-                SuccessResult $ RunInteractiveOption $ MkRunOptions [] $ Just "dpath"
-              , testOptions ["--interactive"] $ SuccessResult $ RunInteractiveOption $ MkRunOptions [] Nothing
+                SuccessResult $ RunInteractiveOption $ MkRunOptions [] (Just "dpath") False
+              , testOptions ["--interactive"] $ SuccessResult $ RunInteractiveOption $ MkRunOptions [] Nothing False
               , testOptions ["-I", "incpath", "--interactive"] $
-                SuccessResult $ RunInteractiveOption $ MkRunOptions ["incpath"] Nothing
+                SuccessResult $ RunInteractiveOption $ MkRunOptions ["incpath"] Nothing False
               , testOptions ["--include", "incpath", "--interactive"] $
-                SuccessResult $ RunInteractiveOption $ MkRunOptions ["incpath"] Nothing
+                SuccessResult $ RunInteractiveOption $ MkRunOptions ["incpath"] Nothing False
               , testOptions ["--interactive", "-I", "incpath"] $
-                SuccessResult $ RunInteractiveOption $ MkRunOptions ["incpath"] Nothing
+                SuccessResult $ RunInteractiveOption $ MkRunOptions ["incpath"] Nothing False
               , testOptions ["-I", "path1", "-I", "path2", "--interactive"] $
-                SuccessResult $ RunInteractiveOption $ MkRunOptions ["path1", "path2"] Nothing
+                SuccessResult $ RunInteractiveOption $ MkRunOptions ["path1", "path2"] Nothing False
               , testOptions ["--include", "path1", "--include", "path2", "--interactive"] $
-                SuccessResult $ RunInteractiveOption $ MkRunOptions ["path1", "path2"] Nothing
+                SuccessResult $ RunInteractiveOption $ MkRunOptions ["path1", "path2"] Nothing False
               , testOptions ["--interactive", "-I", "path1", "-I", "path2"] $
-                SuccessResult $ RunInteractiveOption $ MkRunOptions ["path1", "path2"] Nothing
+                SuccessResult $ RunInteractiveOption $ MkRunOptions ["path1", "path2"] Nothing False
               , testOptions ["--interactive", "--data", "dpath"] $
-                SuccessResult $ RunInteractiveOption $ MkRunOptions [] $ Just "dpath"
+                SuccessResult $ RunInteractiveOption $ MkRunOptions [] (Just "dpath") False
+              , testOptions ["--interactive", "--sloppy", "--data", "dpath"] $
+                SuccessResult $ RunInteractiveOption $ MkRunOptions [] (Just "dpath") True
               ]
         ]
 

diff --git a/Pinafore/pinafore-app/app/main/test/option-help.ref b/Pinafore/pinafore-app/app/main/test/option-help.ref
@@ -2,5 +2,5 @@ Invalid option `--help'
 
 Usage: pinafore ((-v|--version) | 
                   ((-i|--interactive) | [-n|--no-run] [--imply name=value] PATH)
-                  [-I|--include PATH] [--data PATH] |
+                  [-I|--include PATH] [--data PATH] [--sloppy] |
                   --dump-table [--data PATH])
diff --git a/Pinafore/pinafore-app/benchmark/Main.hs b/Pinafore/pinafore-app/benchmark/Main.hs
@@ -27,17 +27,18 @@ benchHashes =
               "1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890"
         ]
 
-getBenchEnv :: IO (() -> LibraryContext)
+getBenchEnv :: IO (() -> InterpretBehaviour)
 getBenchEnv = let
-    library = mkLibraryContext $ libraryLoadModule appLibrary
-    in return $ \() -> library
+    ibLoadModule = libraryLoadModule appLibrary
+    ibSloppy = False
+    in return $ \() -> MkInterpretBehaviour {..}
 
 benchScript :: Text -> Benchmark
 benchScript text =
     env getBenchEnv $ \tpc -> let
-        library = tpc ()
+        behaviour = tpc ()
         in let
-               ?library = library
+               ?behaviour = behaviour
                in bgroup
                       (show $ unpack text)
                       [ bench "check" $

diff --git a/Pinafore/pinafore-app/lib/Pinafore/Options.hs b/Pinafore/pinafore-app/lib/Pinafore/Options.hs
@@ -13,6 +13,7 @@ import System.FilePath
 data RunOptions = MkRunOptions
     { roIncludeDirs :: [FilePath]
     , roDataDir :: Maybe FilePath
+    , roSloppy :: Bool
     } deriving (Eq, Show)
 
 getModuleOptions :: RunOptions -> IO ModuleOptions

diff --git a/Pinafore/pinafore-app/test/Test/Library.hs b/Pinafore/pinafore-app/test/Test/Library.hs
@@ -19,11 +19,12 @@ testLibrary =
         moduleNames :: [ModuleName]
         moduleNames = fmap lmName appLibrary
         in let
-               ?library = standardLibraryContext MkModuleOptions {..}
+               ?behaviour = MkInterpretBehaviour
+                   {ibSloppy = False, ibLoadModule = standardLoadModule MkModuleOptions {..}}
                in for_ moduleNames $ \modname -> do
                       mmod <-
                           fromInterpretResult $
-                          runPinaforeScoped (show modname) $ runLoadModule (lcLoadModule ?library) modname
+                          runPinaforeScoped (show modname) $ runLoadModule (ibLoadModule ?behaviour) modname
                       pmodule <- maybeToM (show modname <> ": not found") mmod
                       for_ (moduleScopeEntries pmodule) $ \(_, binfo) -> do
                           let oname = biOriginalName binfo

diff --git a/Pinafore/pinafore-docgen/app/Options.hs b/Pinafore/pinafore-docgen/app/Options.hs
@@ -22,7 +22,7 @@ optDataPath :: Parser (Maybe FilePath)
 optDataPath = optional $ strOption $ long "data" <> metavar "PATH"
 
 optRunOptions :: Parser RunOptions
-optRunOptions = MkRunOptions <$> optIncludes <*> optDataPath
+optRunOptions = MkRunOptions <$> optIncludes <*> optDataPath <*> switch (long "sloppy")
 
 optParser :: Parser Options
 optParser =

diff --git a/Pinafore/pinafore-docgen/lib/Pinafore/DocGen.hs b/Pinafore/pinafore-docgen/lib/Pinafore/DocGen.hs
@@ -24,7 +24,7 @@ trimDoc (MkTree n children) = MkTree n $ trimDocChildren children
 
 generateCommonMarkDoc :: Handle -> ModuleOptions -> ModuleName -> IO ()
 generateCommonMarkDoc outh modopts modname = do
-    let ?library = standardLibraryContext modopts
+    let ?behaviour = MkInterpretBehaviour {ibLoadModule = standardLoadModule modopts, ibSloppy = False}
     docs <- getModuleDocs modname
     let
         runDocTree :: Int -> Int -> Tree DefDoc -> IO ()

diff --git a/Pinafore/pinafore-docgen/test/Main.hs b/Pinafore/pinafore-docgen/test/Main.hs
@@ -29,6 +29,7 @@ main = do
     let
         roIncludeDirs = ["test" </> "golden"]
         roDataDir = Nothing
+        roSloppy = False
     mo <- getModuleOptions MkRunOptions {..}
     let
         testGolden :: TestTree

diff --git a/Pinafore/pinafore-language/lib/Pinafore/Documentation.hs b/Pinafore/pinafore-language/lib/Pinafore/Documentation.hs
@@ -48,7 +48,7 @@ libraryTypeNames lm = toList (lmContents lm) >>= bindDocTypeName
 allTypeNames :: [Name]
 allTypeNames = filter (not . nameIsInfix) $ sort $ nub $ pinaforeLibrary >>= libraryTypeNames
 
-getModuleDocs :: (?library :: LibraryContext) => ModuleName -> IO Docs
+getModuleDocs :: (?behaviour :: InterpretBehaviour) => ModuleName -> IO Docs
 getModuleDocs modname = do
     qmodule <- fromInterpretResult $ runPinaforeScoped "<doc>" $ getModule modname
     return $ moduleDoc qmodule
diff --git a/Pinafore/pinafore-language/lib/Pinafore/Language.hs b/Pinafore/pinafore-language/lib/Pinafore/Language.hs
@@ -7,8 +7,7 @@ module Pinafore.Language
     , libraryLoadModule
     , QModule(..)
     , getModule
-    , LibraryContext(..)
-    , mkLibraryContext
+    , InterpretBehaviour(..)
     , pinaforeLibrary
     , QError
     , fromParseResult
@@ -42,7 +41,7 @@ import Pinafore.Language.Interpreter
 import Pinafore.Language.Library
 import Pinafore.Language.Var
 
-interact :: (?library :: LibraryContext) => Handle -> Handle -> Bool -> View ()
+interact :: (?behaviour :: InterpretBehaviour) => Handle -> Handle -> Bool -> View ()
 interact inh outh echo = do
     liftIO $ hSetBuffering outh NoBuffering
     runInteract inh outh echo $ fromInterpretResult . runPinaforeScoped "<UNKNOWN>"
diff --git a/Pinafore/pinafore-language/lib/Pinafore/Language/Error.hs b/Pinafore/pinafore-language/lib/Pinafore/Language/Error.hs
@@ -2,9 +2,21 @@ module Pinafore.Language.Error where
 
 import Import
 
+data QWarningType =
+    TestQWarningType
+
+instance ShowNamedText QWarningType where
+    showNamedText TestQWarningType = "test warning"
+
+type QWarning = SourceError QWarningType
+
+emitWarning :: QWarning -> IO ()
+emitWarning w = hPutStrLn stderr $ unpack $ "warning: " <> (toText $ showNamedText w)
+
 data QErrorType
     = InternalError (Maybe Int)
                     NamedText
+    | WarningError QWarningType
     | UnicodeDecodeError NamedText
     | ParserError ParseErrorType
     | PatternErrorError PatternError
@@ -83,6 +95,7 @@ instance ShowNamedText QErrorType where
                 (Just n, _) -> "INTERNAL ERROR: " <> toNamedText t <> " (issue #" <> showNamedText n <> ")"
                 (Nothing, "") -> "INTERNAL ERROR"
                 (Nothing, _) -> "INTERNAL ERROR: " <> toNamedText t
+    showNamedText (WarningError w) = showNamedText w <> " (use --sloppy to ignore)"
     showNamedText (UnicodeDecodeError t) = "Unicode decode error: " <> t
     showNamedText (ParserError err) = showNamedText err
     showNamedText (PatternErrorError e) = showNamedText e

diff --git a/Pinafore/pinafore-language/lib/Pinafore/Language/Interpret.hs b/Pinafore/pinafore-language/lib/Pinafore/Language/Interpret.hs
@@ -64,8 +64,8 @@ parseToValueSubsume t text = do
     val <- parseToValue text []
     tsSubsumeValue @QTypeSystem t val
 
-runPinaforeScoped :: (?library :: LibraryContext) => String -> QInterpreter a -> InterpretResult a
+runPinaforeScoped :: (?behaviour :: InterpretBehaviour) => String -> QInterpreter a -> InterpretResult a
 runPinaforeScoped sourcename ma =
-    runInterpreter (initialPos sourcename) ?library $ do
+    runInterpreter (initialPos sourcename) ?behaviour $ do
         sd <- interpretImportDeclaration builtInModuleName
         withScopeDocs sd ma