diff --git a/lib/index.js b/lib/index.js index 2bc7a3e9c..21b6e6972 100644 --- a/lib/index.js +++ b/lib/index.js @@ -327,7 +327,7 @@ module.exports = { package: !!options.package }); }, - make: async (config, path, options) => { + make: async (config, path, options = {}) => { return await runGuida(config, { command: "make", path, diff --git a/src/API/Main.elm b/src/API/Main.elm index 2b4166116..d9540c910 100644 --- a/src/API/Main.elm +++ b/src/API/Main.elm @@ -53,8 +53,20 @@ app = |> Task.bind (\result -> case result of - Ok output -> - exitWithResponse (Encode.object [ ( "output", Encode.string output ) ]) + Ok ( output, warnings ) -> + let + warningsJson : Encode.Value + warningsJson = + E.encodeUgly (E.list Error.warningReportToJson warnings) + |> Decode.decodeString Decode.value + |> Result.withDefault Encode.null + in + exitWithResponse + (Encode.object + [ ( "output", Encode.string output ) + , ( "warnings", warningsJson ) + ] + ) Err error -> exitWithResponse (Encode.object [ ( "error", Encode.string (E.encodeUgly (Exit.toJson (Exit.makeToReport error))) ) ]) diff --git a/src/API/Make.elm b/src/API/Make.elm index 3c6e33b26..2f3f07174 100644 --- a/src/API/Make.elm +++ b/src/API/Make.elm @@ -21,7 +21,12 @@ import Builder.Stuff as Stuff import Compiler.AST.Optimized as Opt import Compiler.Data.NonEmptyList as NE import Compiler.Generate.Html as Html +import Compiler.Generate.Target exposing (Target) import Compiler.Guida.ModuleName as ModuleName +import Compiler.Reporting.Render.Code as Code +import Compiler.Reporting.Render.Type.Localizer as L +import Compiler.Reporting.Report as Report +import Compiler.Reporting.Warning as W import Maybe.Extra as Maybe import Task exposing (Task) import Terminal.Terminal.Internal exposing (Parser(..)) @@ -52,7 +57,7 @@ type ReportType -- RUN -run : String -> Flags -> Task Never (Result Exit.Make String) +run : String -> Flags -> Task Never (Result Exit.Make ( String, List Report.WarningModuleReport )) run path flags = Stuff.findRoot |> Task.bind @@ -66,7 +71,7 @@ run path flags = ) -runHelp : Stuff.Root -> String -> Flags -> Task Never (Result Exit.Make String) +runHelp : Stuff.Root -> String -> Flags -> Task Never (Result Exit.Make ( String, List Report.WarningModuleReport )) runHelp root path (Flags debug optimize withSourceMaps) = BW.withScope (\scope -> @@ -83,17 +88,32 @@ runHelp root path (Flags debug optimize withSourceMaps) = Task.eio Exit.MakeBadDetails (Details.load style scope root) |> Task.bind (\details -> - buildPaths style root details (NE.Nonempty path []) + buildPaths style root details False False (NE.Nonempty path []) |> Task.bind - (\artifacts -> + (\((Build.Artifacts warnings _ _ _ _) as artifacts) -> case getMains artifacts of [] -> -- Task.pure () crash "No main!" [ name ] -> - toBuilder withSourceMaps Html.leadingLines root details desiredMode artifacts - |> Task.bind (Task.pure << Html.sandwich (Stuff.rootToTarget root) name) + let + target : Target + target = + Stuff.rootToTarget root + + buildOutput : Task Exit.Make String + buildOutput = + toBuilder withSourceMaps Html.leadingLines root details desiredMode artifacts + |> Task.fmap (Html.sandwich target name) + + buildWarnings : Task Exit.Make (List Report.WarningModuleReport) + buildWarnings = + warnings + |> Utils.listTraverse (warningToReport target) + |> Task.mapError never + in + Task.map2 Tuple.pair buildOutput buildWarnings _ -> crash "TODO" @@ -128,10 +148,23 @@ getMode debug optimize = -- BUILD PROJECTS -buildPaths : Reporting.Style -> Stuff.Root -> Details.Details -> NE.Nonempty FilePath -> Task Exit.Make Build.Artifacts -buildPaths style root details paths = +buildPaths : Reporting.Style -> Stuff.Root -> Details.Details -> Bool -> Bool -> NE.Nonempty FilePath -> Task Exit.Make Build.Artifacts +buildPaths style root details suppressWarnings denyWarnings paths = Task.eio Exit.MakeCannotBuild <| - Build.fromPaths style root details paths + Build.fromPaths style root details suppressWarnings denyWarnings paths + + + +-- EXTRACT WARNINGS + + +warningToReport : Target -> W.Module -> Task Never Report.WarningModuleReport +warningToReport target { absolutePath, name, source, warnings } = + Task.pure + { path = absolutePath + , name = name + , warnings = List.map (W.toReport target L.empty (Code.toSource source)) warnings + } @@ -139,7 +172,7 @@ buildPaths style root details paths = getMains : Build.Artifacts -> List ModuleName.Raw -getMains (Build.Artifacts _ _ roots modules) = +getMains (Build.Artifacts _ _ _ roots modules) = List.filterMap (getMain modules) (NE.toList roots) diff --git a/src/Builder/Build.elm b/src/Builder/Build.elm index ce7f8e089..eb8ed0fb3 100644 --- a/src/Builder/Build.elm +++ b/src/Builder/Build.elm @@ -46,6 +46,7 @@ import Compiler.Reporting.Error.Docs as EDocs import Compiler.Reporting.Error.Import as Import import Compiler.Reporting.Error.Syntax as Syntax import Compiler.Reporting.Render.Type.Localizer as L +import Compiler.Reporting.Warning as W import Data.Graph as Graph import Data.Map as Dict exposing (Dict) import Data.Set as EverySet @@ -134,7 +135,7 @@ forkWithKey toComparable keyComparison encoder func dict = fromExposed : BD.Decoder docs -> (docs -> BE.Encoder) -> Reporting.Style -> Stuff.Root -> Details.Details -> DocsGoal docs -> NE.Nonempty ModuleName.Raw -> Task Never (Result Exit.BuildProblem docs) fromExposed docsDecoder docsEncoder style root details docsGoal ((NE.Nonempty e es) as exposed) = - Reporting.trackBuild docsDecoder docsEncoder style <| + Reporting.trackBuild docsDecoder docsEncoder style (\_ -> ( 0, False, False )) <| \key -> makeEnv key root details |> Task.bind @@ -208,7 +209,7 @@ fromExposed docsDecoder docsEncoder style root details docsGoal ((NE.Nonempty e type Artifacts - = Artifacts Pkg.Name Dependencies (NE.Nonempty Root) (List Module) + = Artifacts (List W.Module) Pkg.Name Dependencies (NE.Nonempty Root) (List Module) type Module @@ -220,9 +221,9 @@ type alias Dependencies = Dict (List String) TypeCheck.Canonical I.DependencyInterface -fromPaths : Reporting.Style -> Stuff.Root -> Details.Details -> NE.Nonempty FilePath -> Task Never (Result Exit.BuildProblem Artifacts) -fromPaths style root details paths = - Reporting.trackBuild artifactsDecoder artifactsEncoder style <| +fromPaths : Reporting.Style -> Stuff.Root -> Details.Details -> Bool -> Bool -> NE.Nonempty FilePath -> Task Never (Result Exit.BuildProblem Artifacts) +fromPaths style root details suppressWarnings denyWarnings paths = + Reporting.trackBuild artifactsDecoder artifactsEncoder style (\(Artifacts warnModules _ _ _ _) -> ( List.length (List.concatMap .warnings warnModules), suppressWarnings, denyWarnings )) <| \key -> makeEnv key root details |> Task.bind @@ -300,7 +301,7 @@ fromPaths style root details paths = getRootNames : Artifacts -> NE.Nonempty ModuleName.Raw -getRootNames (Artifacts _ _ roots _) = +getRootNames (Artifacts _ _ _ roots _) = NE.map getRootName roots @@ -486,9 +487,9 @@ type alias ResultDict = type BResult - = RNew Details.Local I.Interface Opt.LocalGraph (Maybe Docs.Module) - | RSame Details.Local I.Interface Opt.LocalGraph (Maybe Docs.Module) - | RCached Bool Details.BuildID (MVar CachedInterface) + = RNew W.Module Details.Local I.Interface Opt.LocalGraph (Maybe Docs.Module) + | RSame W.Module Details.Local I.Interface Opt.LocalGraph (Maybe Docs.Module) + | RCached (Maybe W.Module) Bool Details.BuildID (MVar CachedInterface) | RNotFound Import.Problem | RProblem Error.Module | RBlocked @@ -528,10 +529,14 @@ checkModule ((Env _ root projectType _ _ _ _) as env) foreigns resultsMVar name ) DepsSame _ _ -> - Utils.newMVar cachedInterfaceEncoder Unneeded - |> Task.fmap - (\mvar -> - RCached hasMain lastChange mvar + File.readBinary W.moduleDecoder (Stuff.guidaw (Stuff.rootPath root) name) + |> Task.bind + (\maybeWarningModule -> + Utils.newMVar cachedInterfaceEncoder Unneeded + |> Task.fmap + (\mvar -> + RCached maybeWarningModule hasMain lastChange mvar + ) ) DepsBlock -> @@ -641,13 +646,13 @@ checkDepsHelp root results deps new same cached importProblems isBlocked lastDep |> Task.bind (\result -> case result of - RNew (Details.Local _ _ _ _ lastChange _) iface _ _ -> + RNew _ (Details.Local _ _ _ _ lastChange _) iface _ _ -> checkDepsHelp root results otherDeps (( dep, iface ) :: new) same cached importProblems isBlocked (max lastChange lastDepChange) lastCompile - RSame (Details.Local _ _ _ _ lastChange _) iface _ _ -> + RSame _ (Details.Local _ _ _ _ lastChange _) iface _ _ -> checkDepsHelp root results otherDeps new (( dep, iface ) :: same) cached importProblems isBlocked (max lastChange lastDepChange) lastCompile - RCached _ lastChange mvar -> + RCached _ _ lastChange mvar -> checkDepsHelp root results otherDeps new same (( dep, mvar ) :: cached) importProblems isBlocked (max lastChange lastDepChange) lastCompile RNotFound prob -> @@ -966,7 +971,7 @@ checkInside name p1 status = compile : Target -> Env -> DocsNeed -> Details.Local -> String -> Dict String ModuleName.Raw I.Interface -> Src.Module -> Task Never BResult -compile target (Env key root projectType _ buildID _ _) docsNeed (Details.Local path time deps main lastChange _) source ifaces modul = +compile target (Env key root projectType _ buildID _ _) docsNeed (Details.Local path ((File.Time posix) as time) deps main lastChange _) source ifaces modul = let pkg : Pkg.Name pkg = @@ -974,7 +979,7 @@ compile target (Env key root projectType _ buildID _ _) docsNeed (Details.Local in Compile.compile target root pkg ifaces modul |> Task.bind - (\result -> + (\( warnings, result ) -> case result of Ok (Compile.Artifacts canonical annotations objects) -> case makeDocs target docsNeed canonical of @@ -1000,56 +1005,65 @@ compile target (Env key root projectType _ buildID _ _) docsNeed (Details.Local File.writeBinary Opt.localGraphEncoder (Stuff.guidao (Stuff.rootPath root) name) objects |> Task.bind (\_ -> - File.readBinary I.interfaceDecoder guidai + let + warningModule : W.Module + warningModule = + W.Module (Src.getName modul) path posix source warnings + in + File.writeBinary W.moduleEncoder (Stuff.guidaw (Stuff.rootPath root) name) warningModule |> Task.bind - (\maybeOldi -> - case maybeOldi of - Just oldi -> - if oldi == iface then - -- iface should be fully forced by equality check - Reporting.report key Reporting.BDone - |> Task.fmap - (\_ -> - let - local : Details.Local - local = - Details.Local path time deps main lastChange buildID - in - RSame local iface objects docs - ) - - else - File.writeBinary I.interfaceEncoder guidai iface - |> Task.bind - (\_ -> + (\_ -> + File.readBinary I.interfaceDecoder guidai + |> Task.bind + (\maybeOldi -> + case maybeOldi of + Just oldi -> + if oldi == iface then + -- iface should be fully forced by equality check Reporting.report key Reporting.BDone |> Task.fmap (\_ -> let local : Details.Local local = - Details.Local path time deps main buildID buildID + Details.Local path time deps main lastChange buildID in - RNew local iface objects docs + RSame warningModule local iface objects docs + ) + + else + File.writeBinary I.interfaceEncoder guidai iface + |> Task.bind + (\_ -> + Reporting.report key Reporting.BDone + |> Task.fmap + (\_ -> + let + local : Details.Local + local = + Details.Local path time deps main buildID buildID + in + RNew warningModule local iface objects docs + ) ) - ) - _ -> - -- iface may be lazy still - File.writeBinary I.interfaceEncoder guidai iface - |> Task.bind - (\_ -> - Reporting.report key Reporting.BDone - |> Task.fmap + _ -> + -- iface may be lazy still + File.writeBinary I.interfaceEncoder guidai iface + |> Task.bind (\_ -> - let - local : Details.Local - local = - Details.Local path time deps main buildID buildID - in - RNew local iface objects docs + Reporting.report key Reporting.BDone + |> Task.fmap + (\_ -> + let + local : Details.Local + local = + Details.Local path time deps main buildID buildID + in + RNew warningModule local iface objects docs + ) ) - ) + ) ) ) @@ -1083,13 +1097,13 @@ writeDetails root (Details.Details time outline buildID locals foreigns extras) addNewLocal : ModuleName.Raw -> BResult -> Dict String ModuleName.Raw Details.Local -> Dict String ModuleName.Raw Details.Local addNewLocal name result locals = case result of - RNew local _ _ _ -> + RNew _ local _ _ _ -> Dict.insert identity name local locals - RSame local _ _ _ -> + RSame _ local _ _ _ -> Dict.insert identity name local locals - RCached _ _ _ -> + RCached _ _ _ _ -> locals RNotFound _ -> @@ -1130,13 +1144,13 @@ finalizeExposed root docsGoal exposed results = addErrors : BResult -> List Error.Module -> List Error.Module addErrors result errors = case result of - RNew _ _ _ _ -> + RNew _ _ _ _ _ -> errors - RSame _ _ _ _ -> + RSame _ _ _ _ _ -> errors - RCached _ _ _ -> + RCached _ _ _ _ -> errors RNotFound _ -> @@ -1155,16 +1169,47 @@ addErrors result errors = errors +gatherWarnings : BResult -> List W.Module -> List W.Module +gatherWarnings result warnings = + case result of + RNew ws _ _ _ _ -> + ws :: warnings + + RSame ws _ _ _ _ -> + ws :: warnings + + RCached Nothing _ _ _ -> + warnings + + RCached (Just ws) _ _ _ -> + ws :: warnings + + RNotFound _ -> + warnings + + RProblem _ -> + warnings + + RBlocked -> + warnings + + RForeign _ -> + warnings + + RKernel -> + warnings + + addImportProblems : Dict String ModuleName.Raw BResult -> ModuleName.Raw -> List ( ModuleName.Raw, Import.Problem ) -> List ( ModuleName.Raw, Import.Problem ) addImportProblems results name problems = case Utils.find identity name results of - RNew _ _ _ _ -> + RNew _ _ _ _ _ -> problems - RSame _ _ _ _ -> + RSame _ _ _ _ _ -> problems - RCached _ _ _ -> + RCached _ _ _ _ -> problems RNotFound p -> @@ -1255,13 +1300,13 @@ finalizeDocs goal results = toDocs : BResult -> Maybe Docs.Module toDocs result = case result of - RNew _ _ _ d -> + RNew _ _ _ _ d -> d - RSame _ _ _ d -> + RSame _ _ _ _ d -> d - RCached _ _ _ -> + RCached _ _ _ _ -> Nothing RNotFound _ -> @@ -1380,7 +1425,7 @@ finalizeReplArtifacts ((Env _ root projectType _ _ _ _) as env) source ((Src.Mod compileInput ifaces = Compile.compile (Stuff.rootToTarget root) root pkg ifaces modul |> Task.fmap - (\result -> + (\( _, result ) -> case result of Ok (Compile.Artifacts ((Can.Module name _ _ _ _ _ _ _) as canonical) annotations objects) -> let @@ -1739,7 +1784,7 @@ compileOutside (Env key root projectType _ _ _ _) (Details.Local path time _ _ _ in Compile.compile (Stuff.rootToTarget root) root pkg ifaces modul |> Task.bind - (\result -> + (\( _, result ) -> case result of Ok (Compile.Artifacts canonical annotations objects) -> Reporting.report key Reporting.BDone @@ -1766,8 +1811,13 @@ toArtifacts (Env _ root projectType _ _ _ _) foreigns results rootResults = Err (Exit.BuildBadModules (Stuff.rootPath root) e es) Ok roots -> + let + warnings : List W.Module + warnings = + Dict.foldr compare (\_ -> gatherWarnings) [] results + in Ok <| - Artifacts (projectTypeToPkg projectType) foreigns roots <| + Artifacts warnings (projectTypeToPkg projectType) foreigns roots <| Dict.foldr compare addInside (NE.foldr addOutside [] rootResults) results @@ -1819,13 +1869,13 @@ gatherProblemsOrMains results (NE.Nonempty rootResult rootResults) = addInside : ModuleName.Raw -> BResult -> List Module -> List Module addInside name result modules = case result of - RNew _ iface objs _ -> + RNew _ _ iface objs _ -> Fresh name iface objs :: modules - RSame _ iface objs _ -> + RSame _ _ iface objs _ -> Fresh name iface objs :: modules - RCached main _ mvar -> + RCached _ main _ mvar -> Cached name main mvar :: modules RNotFound _ -> @@ -1877,27 +1927,30 @@ dictRawMVarBResultEncoder = bResultEncoder : BResult -> BE.Encoder bResultEncoder bResult = case bResult of - RNew local iface objects docs -> + RNew warnings local iface objects docs -> BE.sequence [ BE.unsignedInt8 0 + , W.moduleEncoder warnings , Details.localEncoder local , I.interfaceEncoder iface , Opt.localGraphEncoder objects , BE.maybe Docs.bytesModuleEncoder docs ] - RSame local iface objects docs -> + RSame warnings local iface objects docs -> BE.sequence [ BE.unsignedInt8 1 + , W.moduleEncoder warnings , Details.localEncoder local , I.interfaceEncoder iface , Opt.localGraphEncoder objects , BE.maybe Docs.bytesModuleEncoder docs ] - RCached main lastChange (MVar ref) -> + RCached warnings main lastChange (MVar ref) -> BE.sequence [ BE.unsignedInt8 2 + , BE.maybe W.moduleEncoder warnings , BE.bool main , BE.int lastChange , BE.int ref @@ -1935,21 +1988,24 @@ bResultDecoder = (\idx -> case idx of 0 -> - BD.map4 RNew + BD.map5 RNew + W.moduleDecoder Details.localDecoder I.interfaceDecoder Opt.localGraphDecoder (BD.maybe Docs.bytesModuleDecoder) 1 -> - BD.map4 RSame + BD.map5 RSame + W.moduleDecoder Details.localDecoder I.interfaceDecoder Opt.localGraphDecoder (BD.maybe Docs.bytesModuleDecoder) 2 -> - BD.map3 RCached + BD.map4 RCached + (BD.maybe W.moduleDecoder) BD.bool BD.int (BD.map MVar BD.int) @@ -2256,9 +2312,10 @@ docsNeedDecoder = artifactsEncoder : Artifacts -> BE.Encoder -artifactsEncoder (Artifacts pkg ifaces roots modules) = +artifactsEncoder (Artifacts warnings pkg ifaces roots modules) = BE.sequence - [ Pkg.nameEncoder pkg + [ BE.list W.moduleEncoder warnings + , Pkg.nameEncoder pkg , dependenciesEncoder ifaces , BE.nonempty rootEncoder roots , BE.list moduleEncoder modules @@ -2267,7 +2324,8 @@ artifactsEncoder (Artifacts pkg ifaces roots modules) = artifactsDecoder : BD.Decoder Artifacts artifactsDecoder = - BD.map4 Artifacts + BD.map5 Artifacts + (BD.list W.moduleDecoder) Pkg.nameDecoder dependenciesDecoder (BD.nonempty rootDecoder) diff --git a/src/Builder/Generate.elm b/src/Builder/Generate.elm index 52f2d5d85..72e3991d0 100644 --- a/src/Builder/Generate.elm +++ b/src/Builder/Generate.elm @@ -38,7 +38,7 @@ import Utils.Task.Extra as Task debug : Bool -> Int -> Stuff.Root -> Details.Details -> Build.Artifacts -> Task Exit.Generate String -debug withSourceMaps leadingLines root details (Build.Artifacts pkg ifaces roots modules) = +debug withSourceMaps leadingLines root details (Build.Artifacts _ pkg ifaces roots modules) = loadObjects (Stuff.rootPath root) details modules |> Task.bind (\loading -> @@ -69,7 +69,7 @@ debug withSourceMaps leadingLines root details (Build.Artifacts pkg ifaces roots dev : Bool -> Int -> Stuff.Root -> Details.Details -> Build.Artifacts -> Task Exit.Generate String -dev withSourceMaps leadingLines root details (Build.Artifacts pkg _ roots modules) = +dev withSourceMaps leadingLines root details (Build.Artifacts _ pkg _ roots modules) = Task.bind finalizeObjects (loadObjects (Stuff.rootPath root) details modules) |> Task.bind (\objects -> @@ -92,7 +92,7 @@ dev withSourceMaps leadingLines root details (Build.Artifacts pkg _ roots module prod : Bool -> Int -> Stuff.Root -> Details.Details -> Build.Artifacts -> Task Exit.Generate String -prod withSourceMaps leadingLines root details (Build.Artifacts pkg _ roots modules) = +prod withSourceMaps leadingLines root details (Build.Artifacts _ pkg _ roots modules) = Task.bind finalizeObjects (loadObjects (Stuff.rootPath root) details modules) |> Task.bind (\objects -> diff --git a/src/Builder/Guida/Details.elm b/src/Builder/Guida/Details.elm index 181c0e9f2..7cd13bf4b 100644 --- a/src/Builder/Guida/Details.elm +++ b/src/Builder/Guida/Details.elm @@ -1158,7 +1158,7 @@ compile target root pkg mvar status = Just results -> Compile.compile target root pkg (Utils.mapMapMaybe identity compare getInterface results) modul |> Task.fmap - (\result -> + (\( _, result ) -> case result of Err _ -> Nothing diff --git a/src/Builder/Reporting.elm b/src/Builder/Reporting.elm index 7d3c835f6..759193908 100644 --- a/src/Builder/Reporting.elm +++ b/src/Builder/Reporting.elm @@ -370,8 +370,8 @@ type alias BResult a = Result Exit.BuildProblem a -trackBuild : BD.Decoder a -> (a -> BE.Encoder) -> Style -> (BKey -> Task Never (BResult a)) -> Task Never (BResult a) -trackBuild decoder encoder style callback = +trackBuild : BD.Decoder a -> (a -> BE.Encoder) -> Style -> (a -> ( Int, Bool, Bool )) -> (BKey -> Task Never (BResult a)) -> Task Never (BResult a) +trackBuild decoder encoder style extractWarningInfo callback = case style of Silent -> callback (Key (\_ -> Task.pure ())) @@ -391,7 +391,7 @@ trackBuild decoder encoder style callback = Utils.forkIO (Utils.takeMVar (BD.succeed ()) mvar |> Task.bind (\_ -> putStrFlush "Compiling ...") - |> Task.bind (\_ -> buildLoop decoder chan 0) + |> Task.bind (\_ -> buildLoop decoder chan 0 extractWarningInfo) |> Task.bind (\_ -> Utils.putMVar (\_ -> BE.bool True) mvar ()) ) |> Task.bind (\_ -> callback (Key (Utils.writeChan chanEncoder chan << Err))) @@ -407,8 +407,8 @@ type BMsg = BDone -buildLoop : BD.Decoder a -> Chan (Result BMsg (BResult a)) -> Int -> Task Never () -buildLoop decoder chan done = +buildLoop : BD.Decoder a -> Chan (Result BMsg (BResult a)) -> Int -> (a -> ( Int, Bool, Bool )) -> Task Never () +buildLoop decoder chan done extractWarningInfo = Utils.readChan (BD.result bMsgDecoder (bResultDecoder decoder)) chan |> Task.bind (\msg -> @@ -420,13 +420,13 @@ buildLoop decoder chan done = done + 1 in putStrFlush ("\u{000D}Compiling (" ++ String.fromInt done1 ++ ")") - |> Task.bind (\_ -> buildLoop decoder chan done1) + |> Task.bind (\_ -> buildLoop decoder chan done1 extractWarningInfo) Ok result -> let message : String message = - toFinalMessage done result + toFinalMessage done extractWarningInfo result width : Int width = @@ -443,27 +443,56 @@ buildLoop decoder chan done = ) -toFinalMessage : Int -> BResult a -> String -toFinalMessage done result = +toFinalMessage : Int -> (a -> ( Int, Bool, Bool )) -> BResult a -> String +toFinalMessage done extractWarningInfo result = case result of - Ok _ -> - case done of - 0 -> - "Success!" + Ok value -> + let + ( warningCount, suppressWarnings, denyWarnings ) = + extractWarningInfo value + in + if denyWarnings && warningCount > 0 then + let + warningWord : String + warningWord = + if warningCount == 1 then + "warning" + + else + "warnings" + in + "Failed! (" ++ String.fromInt warningCount ++ " " ++ warningWord ++ ")" + + else + let + warningNote : String + warningNote = + if suppressWarnings || warningCount == 0 then + "" + + else if warningCount == 1 then + " (1 warning)" + + else + " (" ++ String.fromInt warningCount ++ " warnings)" + in + case done of + 0 -> + "Success!" ++ warningNote - 1 -> - "Success! Compiled 1 module." + 1 -> + "Success! Compiled 1 module." ++ warningNote - n -> - "Success! Compiled " ++ String.fromInt n ++ " modules." + n -> + "Success! Compiled " ++ String.fromInt n ++ " modules." ++ warningNote Err problem -> case problem of Exit.BuildBadModules _ _ [] -> "Detected problems in 1 module." - Exit.BuildBadModules _ _ (_ :: ps) -> - "Detected problems in " ++ String.fromInt (2 + List.length ps) ++ " modules." + Exit.BuildBadModules _ _ ps -> + "Detected problems in " ++ String.fromInt (1 + List.length ps) ++ " modules." Exit.BuildProjectProblem _ -> "Detected a problem." diff --git a/src/Builder/Reporting/Exit.elm b/src/Builder/Reporting/Exit.elm index d5a050a39..e1684302c 100644 --- a/src/Builder/Reporting/Exit.elm +++ b/src/Builder/Reporting/Exit.elm @@ -3590,6 +3590,7 @@ toRedirectDoc response = type Make = MakeNoOutline | MakeCannotOptimizeAndDebug + | MakeCannotSuppressAndDenyWarnings | MakeBadDetails Details | MakeAppNeedsFileNames | MakeGuidaPkgNeedsExposing @@ -3633,6 +3634,27 @@ makeToReport make = "I need to take away information to optimize things, and I need to add information to add the debugger. It is impossible to do both at once though! Pick just one of those flags and it should work!" ] + MakeCannotSuppressAndDenyWarnings -> + Help.docReport "CLASHING FLAGS" + Nothing + (D.fillSep + [ D.fromChars "I" + , D.fromChars "cannot" + , D.fromChars "compile" + , D.fromChars "with" + , D.red (D.fromChars "--no-warnings") + , D.fromChars "and" + , D.red (D.fromChars "--deny-warnings") + , D.fromChars "at" + , D.fromChars "the" + , D.fromChars "same" + , D.fromChars "time." + ] + ) + [ D.reflow + "The --no-warnings flag suppresses all warnings, while --deny-warnings treats them as errors. These are contradictory! Pick just one of those flags and it should work!" + ] + MakeBadDetails detailsProblem -> toDetailsReport detailsProblem diff --git a/src/Builder/Stuff.elm b/src/Builder/Stuff.elm index 48e2bb37b..b6f0d09f2 100644 --- a/src/Builder/Stuff.elm +++ b/src/Builder/Stuff.elm @@ -10,6 +10,7 @@ module Builder.Stuff exposing , getReplCache , guidai , guidao + , guidaw , interfaces , isRootGuida , objects @@ -89,6 +90,11 @@ guidai root name = toArtifactPath root name "guidai" +guidaw : String -> ModuleName.Raw -> String +guidaw root name = + toArtifactPath root name "guidaw" + + guidao : String -> ModuleName.Raw -> String guidao root name = toArtifactPath root name "guidao" diff --git a/src/Compiler/Canonicalize/Module.elm b/src/Compiler/Canonicalize/Module.elm index f42f5d9d0..0a5c680e9 100644 --- a/src/Compiler/Canonicalize/Module.elm +++ b/src/Compiler/Canonicalize/Module.elm @@ -1,4 +1,8 @@ -module Compiler.Canonicalize.Module exposing (MResult, canonicalize) +module Compiler.Canonicalize.Module exposing + ( MResult + , UsedModules + , canonicalize + ) import Builder.Stuff as Stuff import Compiler.AST.Canonical as Can @@ -14,6 +18,7 @@ import Compiler.Canonicalize.Type as Type import Compiler.Data.Index as Index import Compiler.Data.Name as Name exposing (Name) import Compiler.Generate.Target exposing (Target) +import Compiler.Guida.Compiler.Imports as DefaultImports import Compiler.Guida.Interface as I import Compiler.Guida.ModuleName as ModuleName import Compiler.Guida.Package as Pkg @@ -24,6 +29,7 @@ import Compiler.Reporting.Result as R import Compiler.Reporting.Warning as W import Data.Graph as Graph import Data.Map as Dict exposing (Dict) +import Data.Set as EverySet import System.TypeCheck.IO as IO import Utils.Crash exposing (crash) @@ -37,10 +43,28 @@ type alias MResult i w a = +-- USED MODULES TRACKING + + +type alias UsedModules = + EverySet.EverySet String ModuleName.Raw + + +trackModule : ModuleName.Raw -> UsedModules -> UsedModules +trackModule moduleName used = + EverySet.insert identity moduleName used + + +trackCanonical : IO.Canonical -> UsedModules -> UsedModules +trackCanonical (IO.Canonical _ moduleName) used = + trackModule moduleName used + + + -- MODULES -canonicalize : Target -> Stuff.Root -> Pkg.Name -> Dict String ModuleName.Raw I.Interface -> Src.Module -> MResult i (List W.Warning) Can.Module +canonicalize : Target -> Stuff.Root -> Pkg.Name -> Dict String ModuleName.Raw I.Interface -> Src.Module -> MResult UsedModules (List W.Warning) Can.Module canonicalize target root pkg ifaces ((Src.Module syntaxVersion _ exports docs imports values _ _ binops effects) as modul) = let home : IO.Canonical @@ -66,12 +90,403 @@ canonicalize target root pkg ifaces ((Src.Module syntaxVersion _ exports docs im (\cexports -> Can.Module home cexports docs cvalues cunions caliases cbinops ceffects ) + |> R.bind + (\canModule -> + extractUsedModules canModule + |> R.bind + (\() -> + generateUnusedImportWarnings target imports + |> R.fmap (\() -> canModule) + ) + ) ) ) ) +-- EXTRACT USED MODULES FROM CANONICAL AST + + +extractUsedModules : Can.Module -> MResult UsedModules (List W.Warning) () +extractUsedModules (Can.Module _ _ _ decls unions aliases _ effects) = + extractUsedFromDecls decls + |> R.bind (\() -> extractUsedFromUnions unions) + |> R.bind (\() -> extractUsedFromAliases aliases) + |> R.bind (\() -> extractUsedFromEffects effects) + + +extractUsedFromDecls : Can.Decls -> MResult UsedModules (List W.Warning) () +extractUsedFromDecls decls = + case decls of + Can.SaveTheEnvironment -> + R.ok () + + Can.Declare def rest -> + extractUsedFromDef def + |> R.bind (\() -> extractUsedFromDecls rest) + + Can.DeclareRec def defs rest -> + extractUsedFromDef def + |> R.bind (\() -> R.traverse extractUsedFromDef defs) + |> R.bind (\_ -> extractUsedFromDecls rest) + + +extractUsedFromDef : Can.Def -> MResult UsedModules (List W.Warning) () +extractUsedFromDef def = + case def of + Can.Def _ patterns expr -> + R.traverse extractUsedFromPattern patterns + |> R.bind (\_ -> extractUsedFromExpr expr) + + Can.TypedDef _ _ patternsAndTypes expr tipe -> + R.traverse (\( p, t ) -> extractUsedFromPattern p |> R.bind (\() -> extractUsedFromType t)) patternsAndTypes + |> R.bind (\_ -> extractUsedFromExpr expr) + |> R.bind (\() -> extractUsedFromType tipe) + + +extractUsedFromExpr : Can.Expr -> MResult UsedModules (List W.Warning) () +extractUsedFromExpr (A.At _ expr_) = + case expr_ of + Can.VarLocal _ -> + R.ok () + + Can.VarTopLevel _ _ -> + R.ok () + + Can.VarKernel _ _ -> + R.ok () + + Can.VarForeign home _ _ -> + trackHome home + + Can.VarCtor _ home _ _ _ -> + trackHome home + + Can.VarDebug home _ _ -> + trackHome home + + Can.VarOperator _ home _ _ -> + trackHome home + + Can.Chr _ -> + R.ok () + + Can.Str _ -> + R.ok () + + Can.Int _ -> + R.ok () + + Can.Float _ -> + R.ok () + + Can.List exprs -> + R.traverse extractUsedFromExpr exprs + |> R.fmap (\_ -> ()) + + Can.Negate expr -> + extractUsedFromExpr expr + + Can.Binop _ home _ _ left right -> + trackHome home + |> R.bind (\() -> extractUsedFromExpr left) + |> R.bind (\() -> extractUsedFromExpr right) + + Can.Lambda patterns body -> + R.traverse extractUsedFromPattern patterns + |> R.bind (\_ -> extractUsedFromExpr body) + + Can.Call func args -> + extractUsedFromExpr func + |> R.bind (\() -> R.traverse extractUsedFromExpr args) + |> R.fmap (\_ -> ()) + + Can.If branches final -> + R.traverse (\( cond, branch ) -> extractUsedFromExpr cond |> R.bind (\() -> extractUsedFromExpr branch)) branches + |> R.bind (\_ -> extractUsedFromExpr final) + + Can.Let def body -> + extractUsedFromDef def + |> R.bind (\() -> extractUsedFromExpr body) + + Can.LetRec defs body -> + R.traverse extractUsedFromDef defs + |> R.bind (\_ -> extractUsedFromExpr body) + + Can.LetDestruct pattern expr body -> + extractUsedFromPattern pattern + |> R.bind (\() -> extractUsedFromExpr expr) + |> R.bind (\() -> extractUsedFromExpr body) + + Can.Case expr branches -> + extractUsedFromExpr expr + |> R.bind (\() -> R.traverse extractUsedFromCaseBranch branches) + |> R.fmap (\_ -> ()) + + Can.Accessor _ -> + R.ok () + + Can.Access expr _ -> + extractUsedFromExpr expr + + Can.Update expr fields -> + let + extractFromFieldUpdate : ( a, Can.FieldUpdate ) -> MResult UsedModules (List W.Warning) () + extractFromFieldUpdate ( _, Can.FieldUpdate _ e ) = + extractUsedFromExpr e + in + extractUsedFromExpr expr + |> R.bind (\() -> R.traverse extractFromFieldUpdate (Dict.toList A.compareLocated fields)) + |> R.fmap (\_ -> ()) + + Can.Record fields -> + R.traverse (\( _, expr ) -> extractUsedFromExpr expr) (Dict.toList A.compareLocated fields) + |> R.fmap (\_ -> ()) + + Can.Unit -> + R.ok () + + Can.Tuple a b rest -> + extractUsedFromExpr a + |> R.bind (\() -> extractUsedFromExpr b) + |> R.bind (\() -> R.traverse extractUsedFromExpr rest) + |> R.fmap (\_ -> ()) + + Can.Shader _ _ -> + R.ok () + + +extractUsedFromCaseBranch : Can.CaseBranch -> MResult UsedModules (List W.Warning) () +extractUsedFromCaseBranch (Can.CaseBranch pattern expr) = + extractUsedFromPattern pattern + |> R.bind (\() -> extractUsedFromExpr expr) + + +extractUsedFromPattern : Can.Pattern -> MResult UsedModules (List W.Warning) () +extractUsedFromPattern (A.At _ pattern_) = + case pattern_ of + Can.PAnything -> + R.ok () + + Can.PVar _ -> + R.ok () + + Can.PRecord _ -> + R.ok () + + Can.PAlias subPattern _ -> + extractUsedFromPattern subPattern + + Can.PUnit -> + R.ok () + + Can.PTuple a b rest -> + extractUsedFromPattern a + |> R.bind (\() -> extractUsedFromPattern b) + |> R.bind (\() -> R.traverse extractUsedFromPattern rest) + |> R.fmap (\_ -> ()) + + Can.PList patterns -> + R.traverse extractUsedFromPattern patterns + |> R.fmap (\_ -> ()) + + Can.PCons head tail -> + extractUsedFromPattern head + |> R.bind (\() -> extractUsedFromPattern tail) + + Can.PBool _ _ -> + R.ok () + + Can.PChr _ -> + R.ok () + + Can.PStr _ _ -> + R.ok () + + Can.PInt _ -> + R.ok () + + Can.PCtor { home, args } -> + trackHome home + |> R.bind (\() -> R.traverse (\(Can.PatternCtorArg _ _ p) -> extractUsedFromPattern p) args) + |> R.fmap (\_ -> ()) + + +extractUsedFromType : Can.Type -> MResult UsedModules (List W.Warning) () +extractUsedFromType tipe = + case tipe of + Can.TLambda arg result -> + extractUsedFromType arg + |> R.bind (\() -> extractUsedFromType result) + + Can.TVar _ -> + R.ok () + + Can.TType home _ args -> + trackHome home + |> R.bind (\() -> R.traverse extractUsedFromType args) + |> R.fmap (\_ -> ()) + + Can.TRecord fields _ -> + R.traverse extractUsedFromFieldType (Dict.values compare fields) + |> R.fmap (\_ -> ()) + + Can.TUnit -> + R.ok () + + Can.TTuple a b rest -> + extractUsedFromType a + |> R.bind (\() -> extractUsedFromType b) + |> R.bind (\() -> R.traverse extractUsedFromType rest) + |> R.fmap (\_ -> ()) + + Can.TAlias home _ args aliasType -> + trackHome home + |> R.bind (\() -> R.traverse (\( _, t ) -> extractUsedFromType t) args) + |> R.fmap (\_ -> ()) + |> R.bind (\() -> extractUsedFromAliasType aliasType) + + +extractUsedFromFieldType : Can.FieldType -> MResult UsedModules (List W.Warning) () +extractUsedFromFieldType (Can.FieldType _ tipe) = + extractUsedFromType tipe + + +extractUsedFromAliasType : Can.AliasType -> MResult UsedModules (List W.Warning) () +extractUsedFromAliasType aliasType = + case aliasType of + Can.Holey tipe -> + extractUsedFromType tipe + + Can.Filled tipe -> + extractUsedFromType tipe + + +extractUsedFromUnions : Dict String Name Can.Union -> MResult UsedModules (List W.Warning) () +extractUsedFromUnions unions = + R.traverse extractUsedFromUnion (Dict.values compare unions) + |> R.fmap (\_ -> ()) + + +extractUsedFromUnion : Can.Union -> MResult UsedModules (List W.Warning) () +extractUsedFromUnion (Can.Union _ ctors _ _) = + R.traverse extractUsedFromCtor ctors + |> R.fmap (\_ -> ()) + + +extractUsedFromCtor : Can.Ctor -> MResult UsedModules (List W.Warning) () +extractUsedFromCtor (Can.Ctor _ _ _ types) = + R.traverse extractUsedFromType types + |> R.fmap (\_ -> ()) + + +extractUsedFromAliases : Dict String Name Can.Alias -> MResult UsedModules (List W.Warning) () +extractUsedFromAliases aliases = + R.traverse extractUsedFromAlias (Dict.values compare aliases) + |> R.fmap (\_ -> ()) + + +extractUsedFromAlias : Can.Alias -> MResult UsedModules (List W.Warning) () +extractUsedFromAlias (Can.Alias _ tipe) = + extractUsedFromType tipe + + +extractUsedFromEffects : Can.Effects -> MResult UsedModules (List W.Warning) () +extractUsedFromEffects effects = + case effects of + Can.NoEffects -> + R.ok () + + Can.Ports ports -> + R.traverse extractUsedFromPort (Dict.values compare ports) + |> R.fmap (\_ -> ()) + + Can.Manager _ _ _ manager -> + extractUsedFromManager manager + + +extractUsedFromPort : Can.Port -> MResult UsedModules (List W.Warning) () +extractUsedFromPort portDef = + case portDef of + Can.Incoming { payload } -> + extractUsedFromType payload + + Can.Outgoing { payload } -> + extractUsedFromType payload + + +extractUsedFromManager : Can.Manager -> MResult UsedModules (List W.Warning) () +extractUsedFromManager manager = + case manager of + Can.Cmd _ -> + R.ok () + + Can.Sub _ -> + R.ok () + + Can.Fx _ _ -> + R.ok () + + +trackHome : IO.Canonical -> MResult UsedModules (List W.Warning) () +trackHome home = + R.modifyInfo (trackCanonical home) + + + +-- GENERATE UNUSED IMPORT WARNINGS + + +generateUnusedImportWarnings : Target -> List Src.Import -> MResult UsedModules (List W.Warning) () +generateUnusedImportWarnings target imports = + R.getInfo + |> R.bind + (\usedModules -> + let + importsToCheck : List Src.Import + importsToCheck = + removeImplicitDefaults target imports + + unusedImports : List ( ModuleName.Raw, A.Region ) + unusedImports = + List.filterMap (checkImportUsed usedModules) importsToCheck + in + R.traverse warnUnusedImport unusedImports + |> R.fmap (\_ -> ()) + ) + + +removeImplicitDefaults : Target -> List Src.Import -> List Src.Import +removeImplicitDefaults target imports = + let + defaultNames : EverySet.EverySet String ModuleName.Raw + defaultNames = + EverySet.fromList identity (List.map Src.getImportName (List.map Src.c1Value (DefaultImports.defaults target))) + in + List.filter (isExplicitImport defaultNames) imports + + +isExplicitImport : EverySet.EverySet String ModuleName.Raw -> Src.Import -> Bool +isExplicitImport defaultNames (Src.Import ( _, A.At (A.Region (A.Position startRow _) _) name ) _ _) = + not (EverySet.member identity name defaultNames && startRow <= 1) + + +checkImportUsed : UsedModules -> Src.Import -> Maybe ( ModuleName.Raw, A.Region ) +checkImportUsed usedModules (Src.Import ( _, A.At region name ) _ _) = + if EverySet.member identity name usedModules then + Nothing + + else + Just ( name, region ) + + +warnUnusedImport : ( ModuleName.Raw, A.Region ) -> MResult UsedModules (List W.Warning) () +warnUnusedImport ( name, region ) = + R.warn (W.UnusedImport region name) + + + -- CANONICALIZE BINOP diff --git a/src/Compiler/Compile.elm b/src/Compiler/Compile.elm index 00dd921e5..ecbea5377 100644 --- a/src/Compiler/Compile.elm +++ b/src/Compiler/Compile.elm @@ -18,9 +18,11 @@ import Compiler.Optimize.Module as Optimize import Compiler.Reporting.Error as E import Compiler.Reporting.Render.Type.Localizer as Localizer import Compiler.Reporting.Result as R +import Compiler.Reporting.Warning as W import Compiler.Type.Constrain.Module as Type import Compiler.Type.Solve as Type import Data.Map exposing (Dict) +import Data.Set as EverySet import System.TypeCheck.IO as TypeCheck import Task exposing (Task) import Utils.Task.Extra as Task @@ -34,39 +36,48 @@ type Artifacts = Artifacts Can.Module (Dict String Name Can.Annotation) Opt.LocalGraph -compile : Target -> Stuff.Root -> Pkg.Name -> Dict String ModuleName.Raw I.Interface -> Src.Module -> Task Never (Result E.Error Artifacts) +compile : Target -> Stuff.Root -> Pkg.Name -> Dict String ModuleName.Raw I.Interface -> Src.Module -> Task Never ( List W.Warning, Result E.Error Artifacts ) compile target root pkg ifaces modul = - Task.pure (canonicalize target root pkg ifaces modul) - |> Task.fmap - (\canonicalResult -> - case canonicalResult of - Ok canonical -> - Result.map2 (\annotations () -> annotations) - (typeCheck target modul canonical) - (nitpick target canonical) - |> Result.andThen - (\annotations -> - optimize target modul annotations canonical - |> Result.map (\objects -> Artifacts canonical annotations objects) - ) - - Err err -> - Err err - ) + let + ( canonicalWarnings, canonicalResult ) = + canonicalize target root pkg ifaces modul + in + case canonicalResult of + Ok canonical -> + case + Result.map2 (\annotations () -> annotations) + (typeCheck target modul canonical) + (nitpick target canonical) + of + Ok annotations -> + let + ( optWarnings, optResult ) = + optimize target modul annotations canonical + in + Task.pure + ( canonicalWarnings ++ optWarnings + , Result.map (\objects -> Artifacts canonical annotations objects) optResult + ) + + Err err -> + Task.pure ( canonicalWarnings, Err err ) + + Err err -> + Task.pure ( canonicalWarnings, Err err ) -- PHASES -canonicalize : Target -> Stuff.Root -> Pkg.Name -> Dict String ModuleName.Raw I.Interface -> Src.Module -> Result E.Error Can.Module +canonicalize : Target -> Stuff.Root -> Pkg.Name -> Dict String ModuleName.Raw I.Interface -> Src.Module -> ( List W.Warning, Result E.Error Can.Module ) canonicalize target root pkg ifaces modul = - case Tuple.second (R.run (Canonicalize.canonicalize target root pkg ifaces modul)) of - Ok canonical -> - Ok canonical + case R.runWithInfo EverySet.empty (Canonicalize.canonicalize target root pkg ifaces modul) of + ( _, warnings, Ok canonical ) -> + ( warnings, Ok canonical ) - Err errors -> - Err (E.BadNames errors) + ( _, warnings, Err errors ) -> + ( warnings, Err (E.BadNames errors) ) typeCheck : Target -> Src.Module -> Can.Module -> Result E.Error (Dict String Name Can.Annotation) @@ -89,11 +100,11 @@ nitpick target canonical = Err (E.BadPatterns errors) -optimize : Target -> Src.Module -> Dict String Name.Name Can.Annotation -> Can.Module -> Result E.Error Opt.LocalGraph +optimize : Target -> Src.Module -> Dict String Name.Name Can.Annotation -> Can.Module -> ( List W.Warning, Result E.Error Opt.LocalGraph ) optimize target ((Src.Module syntaxVersion _ _ _ _ _ _ _ _ _) as modul) annotations canonical = - case Tuple.second (R.run (Optimize.optimize target syntaxVersion annotations canonical)) of - Ok localGraph -> - Ok localGraph + case R.run (Optimize.optimize target syntaxVersion annotations canonical) of + ( warnings, Ok localGraph ) -> + ( warnings, Ok localGraph ) - Err errors -> - Err (E.BadMains (Localizer.fromModule modul) errors) + ( warnings, Err errors ) -> + ( warnings, Err (E.BadMains (Localizer.fromModule modul) errors) ) diff --git a/src/Compiler/Reporting/Error.elm b/src/Compiler/Reporting/Error.elm index f06f411b9..3d33ddeca 100644 --- a/src/Compiler/Reporting/Error.elm +++ b/src/Compiler/Reporting/Error.elm @@ -6,6 +6,7 @@ module Compiler.Reporting.Error exposing , reportToJson , toDoc , toJson + , warningReportToJson ) import Builder.File as File @@ -207,6 +208,15 @@ toJson { name, absolutePath, source, error } = ] +warningReportToJson : Report.WarningModuleReport -> E.Value +warningReportToJson { path, name, warnings } = + E.object + [ ( "path", E.string path ) + , ( "name", E.string name ) + , ( "warnings", E.list reportToJson warnings ) + ] + + reportToJson : Report.Report -> E.Value reportToJson (Report.Report title region _ message) = E.object diff --git a/src/Compiler/Reporting/Report.elm b/src/Compiler/Reporting/Report.elm index 2877fd85b..c87c231f0 100644 --- a/src/Compiler/Reporting/Report.elm +++ b/src/Compiler/Reporting/Report.elm @@ -1,4 +1,7 @@ -module Compiler.Reporting.Report exposing (Report(..)) +module Compiler.Reporting.Report exposing + ( Report(..) + , WarningModuleReport + ) import Compiler.Reporting.Annotation as A import Compiler.Reporting.Doc as D @@ -8,5 +11,12 @@ import Compiler.Reporting.Doc as D -- BUILD REPORTS +type alias WarningModuleReport = + { path : String + , name : String + , warnings : List Report + } + + type Report = Report String A.Region (List String) D.Doc diff --git a/src/Compiler/Reporting/Result.elm b/src/Compiler/Reporting/Result.elm index 1393535f8..d286eacee 100644 --- a/src/Compiler/Reporting/Result.elm +++ b/src/Compiler/Reporting/Result.elm @@ -5,12 +5,15 @@ module Compiler.Reporting.Result exposing , apply , bind , fmap + , getInfo , indexedTraverse , loop , mapTraverseWithKey + , modifyInfo , ok , pure , run + , runWithInfo , throw , traverse , traverseDict @@ -46,6 +49,16 @@ run (RResult k) = ( List.reverse w, Err e ) +runWithInfo : i -> RResult i (List w) e a -> ( i, List w, Result (OneOrMore.OneOrMore e) a ) +runWithInfo initialInfo (RResult k) = + case k initialInfo [] of + ROk finalInfo w a -> + ( finalInfo, List.reverse w, Ok a ) + + RErr finalInfo w e -> + ( finalInfo, List.reverse w, Err e ) + + -- LOOP @@ -102,6 +115,20 @@ throw e = RErr i w (OneOrMore.one e) +modifyInfo : (i -> i) -> RResult i w e () +modifyInfo f = + RResult <| + \i w -> + ROk (f i) w () + + +getInfo : RResult i w e i +getInfo = + RResult <| + \i w -> + ROk i w i + + -- FANCY INSTANCE STUFF diff --git a/src/Compiler/Reporting/Warning.elm b/src/Compiler/Reporting/Warning.elm index a2553ff69..514b595eb 100644 --- a/src/Compiler/Reporting/Warning.elm +++ b/src/Compiler/Reporting/Warning.elm @@ -1,19 +1,43 @@ module Compiler.Reporting.Warning exposing ( Context(..) + , Module , Warning(..) + , contextDecoder + , contextEncoder + , moduleDecoder + , moduleEncoder , toReport + , warningDecoder + , warningEncoder ) import Compiler.AST.Canonical as Can import Compiler.AST.Utils.Type as Type import Compiler.Data.Name exposing (Name) import Compiler.Generate.Target exposing (Target) +import Compiler.Guida.ModuleName as ModuleName import Compiler.Reporting.Annotation as A import Compiler.Reporting.Doc as D import Compiler.Reporting.Render.Code as Code import Compiler.Reporting.Render.Type as RT import Compiler.Reporting.Render.Type.Localizer as L import Compiler.Reporting.Report exposing (Report(..)) +import Time +import Utils.Bytes.Decode as BD +import Utils.Bytes.Encode as BE + + + +-- MODULE + + +type alias Module = + { name : ModuleName.Raw + , absolutePath : String + , modificationTime : Time.Posix + , source : String + , warnings : List Warning + } @@ -82,7 +106,7 @@ toReport target localizer source warning = , D.stack [ D.fromChars "I inferred the type annotation myself though! You can copy it into your code:" , D.green <| - D.hang 4 <| + D.indent 4 <| D.sep [ D.fromName name |> D.a (D.fromChars " :") , RT.canToDoc target localizer RT.None inferredType @@ -99,3 +123,110 @@ defOrPat context def pat = Pattern -> pat + + + +-- ENCODERS and DECODERS + + +moduleEncoder : Module -> BE.Encoder +moduleEncoder modul = + BE.sequence + [ ModuleName.rawEncoder modul.name + , BE.string modul.absolutePath + , BE.int (Time.posixToMillis modul.modificationTime) + , BE.string modul.source + , BE.list warningEncoder modul.warnings + ] + + +moduleDecoder : BD.Decoder Module +moduleDecoder = + BD.map5 Module + ModuleName.rawDecoder + BD.string + (BD.map Time.millisToPosix BD.int) + BD.string + (BD.list warningDecoder) + + +warningEncoder : Warning -> BE.Encoder +warningEncoder warning = + case warning of + UnusedImport region name -> + BE.sequence + [ BE.unsignedInt8 0 + , A.regionEncoder region + , BE.string name + ] + + UnusedVariable region context name -> + BE.sequence + [ BE.unsignedInt8 1 + , A.regionEncoder region + , contextEncoder context + , BE.string name + ] + + MissingTypeAnnotation region name tipe -> + BE.sequence + [ BE.unsignedInt8 2 + , A.regionEncoder region + , BE.string name + , Can.typeEncoder tipe + ] + + +warningDecoder : BD.Decoder Warning +warningDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.map2 UnusedImport + A.regionDecoder + BD.string + + 1 -> + BD.map3 UnusedVariable + A.regionDecoder + contextDecoder + BD.string + + 2 -> + BD.map3 MissingTypeAnnotation + A.regionDecoder + BD.string + Can.typeDecoder + + _ -> + BD.fail + ) + + +contextEncoder : Context -> BE.Encoder +contextEncoder context = + case context of + Def -> + BE.unsignedInt8 0 + + Pattern -> + BE.unsignedInt8 1 + + +contextDecoder : BD.Decoder Context +contextDecoder = + BD.unsignedInt8 + |> BD.andThen + (\idx -> + case idx of + 0 -> + BD.succeed Def + + 1 -> + BD.succeed Pattern + + _ -> + BD.fail + ) diff --git a/src/Terminal/Main.elm b/src/Terminal/Main.elm index c2d7b8fcd..ef2324f7c 100644 --- a/src/Terminal/Main.elm +++ b/src/Terminal/Main.elm @@ -212,6 +212,8 @@ make = |> Terminal.more (Terminal.onOff "debug" "Turn on the time-travelling debugger. It allows you to rewind and replay events. The events can be imported/exported into a file, which makes for very precise bug reports!") |> Terminal.more (Terminal.onOff "optimize" "Turn on optimizations to make code smaller and faster. For example, the compiler renames record fields to be as short as possible and unboxes values to reduce allocation.") |> Terminal.more (Terminal.onOff "sourcemaps" "Add source maps to resulting JavaScript code.") + |> Terminal.more (Terminal.onOff "no-warnings" "Suppress all warnings.") + |> Terminal.more (Terminal.onOff "deny-warnings" "Treat warnings as errors. If set, the build will fail if there are any warnings.") |> Terminal.more (Terminal.flag "output" Make.output "Specify the name of the resulting JS file. For example --output=assets/guida.js to generate the JS at assets/guida.js or --output=/dev/null to generate no output at all!") |> Terminal.more (Terminal.flag "report" Make.reportType "You can say --report=json to get error messages as JSON. This is only really useful if you are an editor plugin. Humans should avoid it!") |> Terminal.more (Terminal.flag "docs" Make.docsFile "Generate a JSON file of documentation for a package. Eventually it will be possible to preview docs with `reactor` because it is quite hard to deal with these JSON files directly.") @@ -226,6 +228,8 @@ make = |> Chomp.apply (Chomp.chompOnOffFlag "debug") |> Chomp.apply (Chomp.chompOnOffFlag "optimize") |> Chomp.apply (Chomp.chompOnOffFlag "sourcemaps") + |> Chomp.apply (Chomp.chompOnOffFlag "no-warnings") + |> Chomp.apply (Chomp.chompOnOffFlag "deny-warnings") |> Chomp.apply (Chomp.chompNormalFlag "output" Make.output Make.parseOutput) |> Chomp.apply (Chomp.chompNormalFlag "report" Make.reportType Make.parseReportType) |> Chomp.apply (Chomp.chompNormalFlag "docs" Make.docsFile Make.parseDocsFile) diff --git a/src/Terminal/Make.elm b/src/Terminal/Make.elm index f13dab38c..5b373999d 100644 --- a/src/Terminal/Make.elm +++ b/src/Terminal/Make.elm @@ -18,12 +18,20 @@ import Builder.Generate as Generate import Builder.Guida.Details as Details import Builder.Reporting as Reporting import Builder.Reporting.Exit as Exit +import Builder.Reporting.Exit.Help as Help import Builder.Stuff as Stuff import Compiler.AST.Optimized as Opt import Compiler.Data.NonEmptyList as NE import Compiler.Generate.Html as Html +import Compiler.Generate.Target exposing (Target) import Compiler.Guida.ModuleName as ModuleName +import Compiler.Reporting.Doc as D +import Compiler.Reporting.Render.Code as Code +import Compiler.Reporting.Render.Type.Localizer as L +import Compiler.Reporting.Report as Report +import Compiler.Reporting.Warning as W import Maybe.Extra as Maybe +import System.Exit as Exit import Task exposing (Task) import Terminal.Terminal.Internal exposing (Parser(..)) import Utils.Bytes.Decode as BD @@ -36,8 +44,13 @@ import Utils.Task.Extra as Task -- FLAGS +type Warnings + = NoWarnings + | Warnings Bool + + type Flags - = Flags Bool Bool Bool (Maybe Output) (Maybe ReportType) (Maybe String) + = Flags Bool Bool Bool Bool Bool (Maybe Output) (Maybe ReportType) (Maybe String) type Output @@ -55,7 +68,7 @@ type ReportType run : List String -> Flags -> Task Never () -run paths ((Flags _ _ _ _ report _) as flags) = +run paths ((Flags _ _ _ _ _ _ report _) as flags) = getStyle report |> Task.bind (\style -> @@ -74,7 +87,7 @@ run paths ((Flags _ _ _ _ report _) as flags) = runHelp : Stuff.Root -> List String -> Reporting.Style -> Flags -> Task Never (Result Exit.Make ()) -runHelp root paths style (Flags debug optimize withSourceMaps maybeOutput _ maybeDocs) = +runHelp root paths style (Flags debug optimize withSourceMaps noWarnings denyWarnings maybeOutput _ maybeDocs) = BW.withScope (\scope -> Stuff.withRootLock (Stuff.rootPath root) <| @@ -82,64 +95,72 @@ runHelp root paths style (Flags debug optimize withSourceMaps maybeOutput _ mayb (getMode debug optimize |> Task.bind (\desiredMode -> - Task.eio Exit.MakeBadDetails (Details.load style scope root) + getWarnings noWarnings denyWarnings |> Task.bind - (\details -> - case paths of - [] -> - getExposed root details - |> Task.bind (\exposed -> buildExposed style root details maybeDocs exposed) - - p :: ps -> - buildPaths style root details (NE.Nonempty p ps) - |> Task.bind - (\artifacts -> - case maybeOutput of - Nothing -> - case getMains artifacts of - [] -> - Task.pure () - - [ name ] -> - toBuilder withSourceMaps Html.leadingLines root details desiredMode artifacts - |> Task.bind - (\builder -> - generate style "index.html" (Html.sandwich (Stuff.rootToTarget root) name builder) (NE.Nonempty name []) - ) - - name :: names -> - toBuilder withSourceMaps 0 root details desiredMode artifacts - |> Task.bind - (\builder -> - generate style "guida.js" builder (NE.Nonempty name names) - ) - - Just DevNull -> - Task.pure () - - Just (JS target) -> - case getNoMains artifacts of - [] -> - toBuilder withSourceMaps 0 root details desiredMode artifacts - |> Task.bind - (\builder -> - generate style target builder (Build.getRootNames artifacts) - ) - - name :: names -> - Task.throw (Exit.MakeNonMainFilesIntoJavaScript name names) - - Just (Html target) -> - hasOneMain artifacts - |> Task.bind - (\name -> - toBuilder withSourceMaps Html.leadingLines root details desiredMode artifacts - |> Task.bind - (\builder -> - generate style target (Html.sandwich (Stuff.rootToTarget root) name builder) (NE.Nonempty name []) - ) - ) - ) + (\warnings -> + Task.eio Exit.MakeBadDetails (Details.load style scope root) + |> Task.bind + (\details -> + case paths of + [] -> + getExposed root details + |> Task.bind (\exposed -> buildExposed style root details maybeDocs exposed) + + p :: ps -> + buildPaths style root details warnings (NE.Nonempty p ps) + |> Task.bind + (\artifacts -> + Task.io (reportWarnings warnings root artifacts) + |> Task.bind + (\_ -> + case maybeOutput of + Nothing -> + case getMains artifacts of + [] -> + Task.pure () + + [ name ] -> + toBuilder withSourceMaps Html.leadingLines root details desiredMode artifacts + |> Task.bind + (\builder -> + generate style "index.html" (Html.sandwich (Stuff.rootToTarget root) name builder) (NE.Nonempty name []) + ) + + name :: names -> + toBuilder withSourceMaps 0 root details desiredMode artifacts + |> Task.bind + (\builder -> + generate style "guida.js" builder (NE.Nonempty name names) + ) + + Just DevNull -> + Task.pure () + + Just (JS target) -> + case getNoMains artifacts of + [] -> + toBuilder withSourceMaps 0 root details desiredMode artifacts + |> Task.bind + (\builder -> + generate style target builder (Build.getRootNames artifacts) + ) + + name :: names -> + Task.throw (Exit.MakeNonMainFilesIntoJavaScript name names) + + Just (Html target) -> + hasOneMain artifacts + |> Task.bind + (\name -> + toBuilder withSourceMaps Html.leadingLines root details desiredMode artifacts + |> Task.bind + (\builder -> + generate style target (Html.sandwich (Stuff.rootToTarget root) name builder) (NE.Nonempty name []) + ) + ) + ) + ) + ) ) ) ) @@ -176,6 +197,22 @@ getMode debug optimize = Task.pure Prod +getWarnings : Bool -> Bool -> Task Exit.Make Warnings +getWarnings noWarnings denyWarnings = + case ( noWarnings, denyWarnings ) of + ( True, True ) -> + Task.throw Exit.MakeCannotSuppressAndDenyWarnings + + ( True, False ) -> + Task.pure NoWarnings + + ( False, False ) -> + Task.pure (Warnings False) + + ( False, True ) -> + Task.pure (Warnings True) + + getExposed : Stuff.Root -> Details.Details -> Task Exit.Make (NE.Nonempty ModuleName.Raw) getExposed root (Details.Details _ validOutline _ _ _ _) = case validOutline of @@ -219,10 +256,19 @@ buildExposed style root details maybeDocs exposed = exposed -buildPaths : Reporting.Style -> Stuff.Root -> Details.Details -> NE.Nonempty FilePath -> Task Exit.Make Build.Artifacts -buildPaths style root details paths = +buildPaths : Reporting.Style -> Stuff.Root -> Details.Details -> Warnings -> NE.Nonempty FilePath -> Task Exit.Make Build.Artifacts +buildPaths style root details warnings paths = + let + ( suppressWarnings, denyWarnings ) = + case warnings of + NoWarnings -> + ( True, False ) + + Warnings deny -> + ( False, deny ) + in Task.eio Exit.MakeCannotBuild <| - Build.fromPaths style root details paths + Build.fromPaths style root details suppressWarnings denyWarnings paths @@ -230,7 +276,7 @@ buildPaths style root details paths = getMains : Build.Artifacts -> List ModuleName.Raw -getMains (Build.Artifacts _ _ roots modules) = +getMains (Build.Artifacts _ _ _ roots modules) = List.filterMap (getMain modules) (NE.toList roots) @@ -264,7 +310,7 @@ isMain targetName modul = hasOneMain : Build.Artifacts -> Task Exit.Make ModuleName.Raw -hasOneMain (Build.Artifacts _ _ roots modules) = +hasOneMain (Build.Artifacts _ _ _ roots modules) = case roots of NE.Nonempty root [] -> Task.mio Exit.MakeNoMain (Task.pure <| getMain modules root) @@ -278,7 +324,7 @@ hasOneMain (Build.Artifacts _ _ roots modules) = getNoMains : Build.Artifacts -> List ModuleName.Raw -getNoMains (Build.Artifacts _ _ roots modules) = +getNoMains (Build.Artifacts _ _ _ roots modules) = List.filterMap (getNoMain modules) (NE.toList roots) @@ -302,6 +348,83 @@ getNoMain modules root = +-- WARNINGS + + +reportWarnings : Warnings -> Stuff.Root -> Build.Artifacts -> Task Never () +reportWarnings warnings root (Build.Artifacts warnList _ _ _ _) = + case warnings of + NoWarnings -> + Task.pure () + + Warnings denyWarnings -> + if List.isEmpty warnList then + Task.pure () + + else + let + rootPath : FilePath + rootPath = + Stuff.rootPath root + + target : Target + target = + Stuff.rootToTarget root + in + Utils.listTraverse (warningToDoc target rootPath) warnList + |> Task.mapError never + |> Task.bind + (\docs -> + Task.io (Help.toStderr (D.vcat (docs ++ [ D.fromChars "" ]))) + |> Task.bind + (\_ -> + if denyWarnings then + Exit.exitFailure + + else + Task.pure () + ) + ) + + +warningToDoc : Target -> FilePath -> W.Module -> Task Never D.Doc +warningToDoc target rootPath { absolutePath, source, warnings } = + let + reports : List Report.Report + reports = + List.map (W.toReport target L.empty (Code.toSource source)) warnings + in + Task.pure (D.vcat (List.map (reportToDoc rootPath absolutePath) reports)) + + +reportToDoc : FilePath -> FilePath -> Report.Report -> D.Doc +reportToDoc rootPath absolutePath (Report.Report title _ _ message) = + D.vcat + [ toMessageBar title (Utils.fpMakeRelative rootPath absolutePath) + , D.fromChars "" + , message + , D.fromChars "" + ] + + +toMessageBar : String -> String -> D.Doc +toMessageBar title filePath = + let + usedSpace : Int + usedSpace = + 4 + String.length title + 1 + String.length filePath + in + D.yellow <| + D.fromChars <| + "-- " + ++ title + ++ " " + ++ String.repeat (max 1 (80 - usedSpace)) "-" + ++ " " + ++ filePath + + + -- GENERATE diff --git a/src/Terminal/Test.elm b/src/Terminal/Test.elm index 9aa373f71..b20932274 100644 --- a/src/Terminal/Test.elm +++ b/src/Terminal/Test.elm @@ -1269,7 +1269,7 @@ runMake root path = buildPaths : Stuff.Root -> Details.Details -> NE.Nonempty FilePath -> Task Exit.Test Build.Artifacts buildPaths root details paths = Task.eio Exit.TestCannotBuild <| - Build.fromPaths Reporting.silent root details paths + Build.fromPaths Reporting.silent root details False False paths diff --git a/tests/api.test.js b/tests/api.test.js index 9e4c82342..5a961e7dc 100644 --- a/tests/api.test.js +++ b/tests/api.test.js @@ -90,6 +90,30 @@ suite = `); }); + it("make - reports warnings", async () => { + const tmpobj = tmp.dirSync(); + process.chdir(tmpobj.name); + + await guida.init(config(), { package: false }); + + fs.writeFileSync(path.join(tmpobj.name, "src", "Main.guida"), `module Main exposing (main) + +main : Program () () () +main = + Platform.worker + { init = \\_ -> ( (), Cmd.none ) + , update = \\_ model -> ( model, Cmd.none ) + , subscriptions = \\_ -> Sub.none + } + +noTypeAnnotationFn unusedVar = 1 +`); + + const result = await guida.make(config(), path.join(tmpobj.name, "src", "Main.guida")); + expect(result).toHaveProperty("output", expect.any(String)); + expect(result).toHaveProperty("warnings", expect.any(Array)); + }); + it.skip("getDefinitionLocation - simple example", async () => { const tmpobj = tmp.dirSync(); process.chdir(tmpobj.name); diff --git a/tests/backwards-compatibility.test.js b/tests/backwards-compatibility.test.js index 6199fbd21..d2848c8d5 100644 --- a/tests/backwards-compatibility.test.js +++ b/tests/backwards-compatibility.test.js @@ -76,7 +76,7 @@ describe("backwards compatibility", () => { try { child_process.execSync( - `../bin/index.js make src/${example}.elm ${commandFlag} --output ${guidaOutput}`, + `../bin/index.js make src/${example}.elm ${commandFlag} --output ${guidaOutput} --no-warnings`, { cwd: path.join(__dirname, "..", "examples") } diff --git a/tests/make.test.js b/tests/make.test.js new file mode 100644 index 000000000..ab85e0010 --- /dev/null +++ b/tests/make.test.js @@ -0,0 +1,89 @@ +const fs = require("node:fs"); +const path = require("node:path"); +const child_process = require("node:child_process"); +const tmp = require("tmp"); +const util = require("node:util"); + +const setupProject = () => { + const tmpobj = tmp.dirSync(); + + child_process.execSync(`${path.join(__dirname, "..", "bin", "index.js")} init --yes`, { + cwd: tmpobj.name, + stdio: "pipe" + }); + + fs.writeFileSync(path.join(tmpobj.name, "src", "WarningFlags.guida"), `module WarningFlags exposing (main) + +import List exposing (map) + +main : Program () () () +main = + Platform.worker + { init = \\_ -> ( (), Cmd.none ) + , update = \\_ model -> ( model, Cmd.none ) + , subscriptions = \\_ -> Sub.none + } + +noTypeAnnotationFn unusedVar = + 1 +`); + + return tmpobj; +}; + +const runMake = (cwd, args) => { + const result = child_process.spawnSync( + path.join(__dirname, "..", "bin", "index.js"), + ["make", "src/WarningFlags.guida", "--output", "warning-flags.js", ...args], + { cwd, encoding: "utf-8" } + ); + + return { + status: result.status, + stdout: util.stripVTControlCharacters(result.stdout || ""), + stderr: util.stripVTControlCharacters(result.stderr || "") + }; +}; + +describe("guida make warning flags", () => { + it("suppresses warnings with --no-warnings", () => { + const tmpobj = setupProject(); + + const result = runMake(tmpobj.name, ["--no-warnings"]); + + expect(result.status).toBe(0); + expect(result.stderr).not.toMatch(/unused import|unused variable|missing type annotation/); + expect(fs.existsSync(path.join(tmpobj.name, "warning-flags.js"))).toBe(true); + }); + + it("fails with --deny-warnings when warnings are present", () => { + const tmpobj = setupProject(); + + const result = runMake(tmpobj.name, ["--deny-warnings"]); + + expect(result.status).toBe(1); + expect(result.stderr).toMatch(/unused import/); + expect(result.stderr).toMatch(/unused variable/); + expect(result.stderr).toMatch(/missing type annotation/); + }); + + it("does not write output file with --deny-warnings", () => { + const tmpobj = setupProject(); + + const result = runMake(tmpobj.name, ["--deny-warnings"]); + + expect(result.status).toBe(1); + expect(fs.existsSync(path.join(tmpobj.name, "warning-flags.js"))).toBe(false); + }); + + it("fails when combining --no-warnings and --deny-warnings", () => { + const tmpobj = setupProject(); + + const result = runMake(tmpobj.name, ["--no-warnings", "--deny-warnings"]); + + expect(result.status).toBe(1); + expect(result.stderr).toMatch(/CLASHING FLAGS/); + expect(result.stderr).toMatch(/--no-warnings/); + expect(result.stderr).toMatch(/--deny-warnings/); + }); +});