diff --git a/builder/src/Build.hs b/builder/src/Build.hs index f05486afa..9f2a910d1 100644 --- a/builder/src/Build.hs +++ b/builder/src/Build.hs @@ -708,7 +708,7 @@ compile (Env key root projectType _ buildID _ _) docsNeed (Details.Local path ti let pkg = projectTypeToPkg projectType in - case Compile.compile pkg ifaces modul of + case Compile.compile (Just (FP.makeRelative root path)) pkg ifaces modul of Right (Compile.Artifacts canonical annotations objects) -> case makeDocs docsNeed canonical of Left err -> @@ -926,7 +926,7 @@ finalizeReplArtifacts env@(Env _ root projectType _ _ _ _) source modul@(Src.Mod projectTypeToPkg projectType compileInput ifaces = - case Compile.compile pkg ifaces modul of + case Compile.compile Nothing pkg ifaces modul of Right (Compile.Artifacts canonical annotations objects) -> let h = Can._name canonical @@ -1173,12 +1173,12 @@ checkRoot env@(Env _ root _ _ _ _ _) results rootStatus = compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO RootResult -compileOutside (Env key _ projectType _ _ _ _) (Details.Local path time _ _ _ _) source ifaces modul = +compileOutside (Env key root projectType _ _ _ _) (Details.Local path time _ _ _ _) source ifaces modul = let pkg = projectTypeToPkg projectType name = Src.getName modul in - case Compile.compile pkg ifaces modul of + case Compile.compile (Just (FP.makeRelative root path)) pkg ifaces modul of Right (Compile.Artifacts canonical annotations objects) -> do Reporting.report key Reporting.BDone return $ ROutsideOk name (I.fromModule pkg canonical annotations) objects @@ -1271,4 +1271,4 @@ lamderaIsLiveHarnessModule modul = lamderaLiveHarnessEnv :: Env -> Env lamderaLiveHarnessEnv env = -- adds the Lamdera cache directory as an additional source directory - env { _srcDirs = AbsoluteSrcDir (Lamdera.lamderaCache $ _root env) : _srcDirs env } \ No newline at end of file + env { _srcDirs = AbsoluteSrcDir (Lamdera.lamderaCache $ _root env) : _srcDirs env } diff --git a/builder/src/Elm/Details.hs b/builder/src/Elm/Details.hs index 29af1b519..536666e1a 100644 --- a/builder/src/Elm/Details.hs +++ b/builder/src/Elm/Details.hs @@ -689,7 +689,7 @@ compile pkg mvar status = return Nothing Just results -> - case Compile.compile pkg (Map.mapMaybe getInterface results) modul of + case Compile.compile Nothing pkg (Map.mapMaybe getInterface results) modul of Left _ -> return Nothing diff --git a/compiler/src/Compile.hs b/compiler/src/Compile.hs index 6468e79ed..2c64b6481 100644 --- a/compiler/src/Compile.hs +++ b/compiler/src/Compile.hs @@ -30,14 +30,11 @@ import qualified Type.Solve as Type import qualified Lamdera.Wire3.Core import qualified Lamdera.Wire3.Interfaces -import qualified Lamdera.Wire3.Helpers as Lamdera.Wire import Lamdera -import qualified CanSer.CanSer as ToSource -import qualified Data.Text as T -import qualified Data.Utf8 import qualified Lamdera.UiSourceMap import qualified Lamdera.Nitpick.DebugLog import qualified Lamdera.Evergreen.ModifyAST +import qualified System.FilePath as FP -- import StandaloneInstances @@ -53,10 +50,10 @@ data Artifacts = } -{- The original compile function for reference -} -compile :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Artifacts -compile pkg ifaces modul = - Lamdera.alternativeImplementationWhen Lamdera.isWireEnabled_ (compile_ pkg ifaces modul) $ +{- The original compile function for reference. `maybePath` parameter added by Lamdera. -} +compile :: Maybe FilePath -> Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Artifacts +compile maybePath pkg ifaces modul = + Lamdera.alternativeImplementationWhen Lamdera.isWireEnabled_ (compile_ maybePath pkg ifaces modul) $ do canonical <- canonicalize pkg ifaces modul annotations <- typeCheck modul canonical () <- nitpick canonical @@ -108,8 +105,8 @@ optimize modul annotations canonical = -- @LAMDERA -compile_ :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Artifacts -compile_ pkg ifaces modul = do +compile_ :: Maybe FilePath -> Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Artifacts +compile_ maybePath pkg ifaces modul = do -- @TEMPORARY debugging -- Inject stub definitions for wire functions, so the canonicalize phase can run -- Necessary for user-code which references yet-to-be generated functions @@ -151,8 +148,13 @@ compile_ pkg ifaces modul = do canonical3 :: Can.Module canonical3 = if (Lamdera.unsafePerformIO Lamdera.isLiveMode) - then Lamdera.UiSourceMap.updateDecls (Can._name canonical2) (Can._decls canonical2) - & (\newDecls -> canonical2 { Can._decls = newDecls }) + then + case maybePath of + Just path -> + Lamdera.UiSourceMap.updateDecls path (Can._name canonical2) (Can._decls canonical2) + & (\newDecls -> canonical2 { Can._decls = newDecls }) + Nothing -> + canonical2 else canonical2 -- () <- debugPassText "starting optimize" moduleName (pure ()) diff --git a/elm.cabal b/elm.cabal index a2a50c24e..34a506994 100644 --- a/elm.cabal +++ b/elm.cabal @@ -266,6 +266,7 @@ Executable lamdera Lamdera.Repl Lamdera.Reporting.Evergreen Lamdera.Reporting.Suggestions + Lamdera.String Lamdera.TypeHash Lamdera.Types Lamdera.Update diff --git a/ext-common/Ext/Common.hs b/ext-common/Ext/Common.hs index 7b4a95711..912aa8b4b 100644 --- a/ext-common/Ext/Common.hs +++ b/ext-common/Ext/Common.hs @@ -420,12 +420,6 @@ cq_ bin args input = do pure $ (exit, stdOut, stdErr) -execCombineStdOutErr :: String -> [String] -> String -> IO String -execCombineStdOutErr bin args input = do - (exit, stdOut, stdErr) <- c_ bin args input - pure $ stdErr <> stdOut - - requireBinary :: String -> IO FilePath requireBinary name = do x <- Dir.findExecutable name diff --git a/ext-common/Ext/Query/Canonical.hs b/ext-common/Ext/Query/Canonical.hs index c5600c369..bf34f159d 100644 --- a/ext-common/Ext/Query/Canonical.hs +++ b/ext-common/Ext/Query/Canonical.hs @@ -54,7 +54,7 @@ loadSingleArtifacts path = do source <- File.readUtf8 path case Parse.fromByteString Parse.Application source of Right modul -> - case Compile.compile Pkg.dummyName ifaces modul of + case Compile.compile Nothing Pkg.dummyName ifaces modul of Right artifacts -> pure artifacts diff --git a/extra/Lamdera/CLI/Live.hs b/extra/Lamdera/CLI/Live.hs index 2ddc7cbf8..3cc146205 100644 --- a/extra/Lamdera/CLI/Live.hs +++ b/extra/Lamdera/CLI/Live.hs @@ -9,6 +9,7 @@ module Lamdera.CLI.Live where import qualified Data.ByteString.Builder as B import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Char8 import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Encoding as TE @@ -20,11 +21,12 @@ import Data.Maybe (fromMaybe) import GHC.Word (Word64) import qualified System.Directory as Dir -import System.FilePath ((), takeExtension) +import qualified System.FilePath as FP +import System.FilePath (()) import Control.Applicative ((<|>)) import Control.Arrow ((***)) import Control.Concurrent.STM (atomically, newTVarIO, readTVar, readTVarIO, writeTVar, TVar) -import Control.Exception (finally) +import Control.Exception (finally, try, SomeException) import qualified Language.Haskell.TH as TH import Data.FileEmbed (bsToExp) import qualified Data.Aeson.Encoding as A @@ -49,12 +51,13 @@ import System.Entropy (getEntropy) import Snap.Util.FileServe ( getSafePath, serveDirectoryWith, defaultDirectoryConfig, defaultMimeTypes, mimeTypes, DirectoryConfig ) -import Control.Monad (guard) +import Control.Monad (guard, mfilter) import qualified Lamdera.CLI.Check import qualified Lamdera.Relative import qualified Lamdera.Version import qualified Ext.Common +import qualified GHC.IO.Exception @@ -119,7 +122,7 @@ directoryConfig = serveUnmatchedUrlsToIndex :: FilePath -> (FilePath -> Snap()) -> Snap () serveUnmatchedUrlsToIndex root serveElm = do file <- getSafePath - guard (takeExtension file == "") + guard (FP.takeExtension file == "") serveElm (lamderaCache root "Lamdera" "Live.elm") @@ -309,26 +312,24 @@ serveWebsocket root (mClients, mLeader, mChan, beState) = openEditorHandler :: FilePath -> Snap () openEditorHandler root = do - fullpath <- T.pack <$> getSafePath - let - handlers = - -- *nix dir paths - [ ("_x/editor", serveEditorOpen root) - -- Windows dir paths - , ("_x\\editor", serveEditorOpen root) - ] - handlers - & List.find (\(prefix, handler) -> - prefix `T.isPrefixOf` fullpath - ) - & fmap (\(prefix, handler) -> do - let path = - fullpath & T.replace (prefix <> "/") "" -- Strip when sub-dirs - & T.replace (prefix <> "\\") "" -- Strip when sub-dirs windows - & T.replace prefix "" -- Strip when root dir - handler path - ) - & withDefault pass + fullpath <- getSafePath + debug $ "_x/editor fullpath: " ++ fullpath + case FP.splitDirectories fullpath of + "_x" : "editor" : rest -> do + maybeRow <- getQueryParam "row" + maybeColumn <- getQueryParam "column" + + let parseNonNegative = mfilter (>= 0) . readMaybe . Data.ByteString.Char8.unpack + + case (maybeRow >>= parseNonNegative, maybeColumn >>= parseNonNegative) of + (Just row, Just column) -> + serveEditorOpen root (FP.joinPath rest) row column + + _ -> + error400PlainText "Unexpected request, expecting format: /_x/editor/?row=&column=" + + _ -> + pass serveBem :: LiveState -> Snap () @@ -426,80 +427,83 @@ serveExperimentalList root path = do error404 "folder not found" -serveEditorOpen :: FilePath -> Text -> Snap () -serveEditorOpen root path = do +serveEditorOpen :: FilePath -> FilePath -> Int -> Int -> Snap () +serveEditorOpen root path row column = do debug $ "_x/editor received: " ++ show path - case path & T.splitOn ":" of - file:row:column:xs -> do - let fullpath = (root T.unpack file) - debug $ "_x/editor: " ++ show fullpath - exists_ <- liftIO $ Dir.doesFileExist fullpath - if exists_ - then do - tryOpenInDetectedEditor root fullpath row column - - else do - error404 "file not found" - _ -> - error404 "unexpected identifier, expecting format: ::" + let fullpath = root path + debug $ "_x/editor: " ++ show fullpath + exists_ <- liftIO $ Dir.doesFileExist fullpath + if exists_ + then do + tryOpenInDetectedEditor root fullpath row column + + else do + error400PlainText "File not found" -tryOpenInDetectedEditor :: FilePath -> FilePath -> Text -> Text -> Snap () +tryOpenInDetectedEditor :: FilePath -> FilePath -> Int -> Int -> Snap () tryOpenInDetectedEditor root file row column = do - res <- liftIO $ mapM id (editors root) + res <- liftIO $ sequence (editors root) case justs res of [] -> - -- @TODO give more helpful error that guides user how to configure things? - error404 "No supported editors found" + error404 "No supported editors found. See the Lamdera docs for more information." - (editor, openEditor):xs -> do + (editor, openEditor):_ -> do debug "📝 found the following editors, opening first:" justs res & fmap fst & show & debug - liftIO $ openEditor file row column - jsonResponse $ "{ status: 'tried opening editor " <> editor <> "' }" + runRes <- liftIO (try (openEditor file row column) :: IO (Either SomeException (GHC.IO.Exception.ExitCode, String, String))) + case runRes of + Right (exit, stdout, stderr) -> + case exit of + GHC.IO.Exception.ExitSuccess -> + noContentResponse + + GHC.IO.Exception.ExitFailure exitCode -> + error400PlainText $ Ext.Common.stringToBuilder $ "exit " <> show exitCode <> ": " <> stdout <> stderr + + Left err -> + error400PlainText $ Ext.Common.stringToBuilder $ show err -type EditorOpenIO = (FilePath -> Text -> Text -> IO String) +type EditorOpenIO = (FilePath -> Int -> Int -> IO (GHC.IO.Exception.ExitCode, String, String)) editors :: FilePath -> [IO (Maybe (B.Builder, EditorOpenIO))] editors projectRoot = [ detectEditor "custom-*nix" (Dir.doesFileExist (projectRoot "openEditor.sh")) - (\file row column -> Ext.Common.execCombineStdOutErr (projectRoot "openEditor.sh") [file, T.unpack row, T.unpack column] "") + (\file row column -> Ext.Common.c_ (projectRoot "openEditor.sh") [file, show row, show column] "") , detectEditor "custom-windows" (do exists <- Dir.doesFileExist (projectRoot "openEditor.bat") pure $ exists && ostype == Windows ) - (\file row column -> Ext.Common.execCombineStdOutErr (projectRoot "openEditor.bat") [file, T.unpack row, T.unpack column] "") + (\file row column -> Ext.Common.c_ (projectRoot "openEditor.bat") [file, show row, show column] "") , detectExecutable "code-insiders" (\executablePath file row column -> do - Ext.Common.execCombineStdOutErr executablePath [ "-g", file <> ":" <> T.unpack row <> ":" <> T.unpack column] "" + Ext.Common.c_ executablePath [ "-g", file <> ":" <> show row <> ":" <> show column] "" ) , detectExecutable "code" (\executablePath file row column -> do - Ext.Common.execCombineStdOutErr executablePath [ "-g", file <> ":" <> T.unpack row <> ":" <> T.unpack column] "" + Ext.Common.c_ executablePath [ "-g", file <> ":" <> show row <> ":" <> show column] "" ) , detectEditor "intellij-ce" (Dir.doesDirectoryExist "/Applications/IntelliJ IDEA CE.app") (\file row column -> do - let column_ :: Int = column & readMaybeText & withDefault 1 -- IntelliJ seems to number it's columns from 1 index - Ext.Common.execCombineStdOutErr "open" ["-na", "IntelliJ IDEA CE.app", "--args", "--line", T.unpack row, "--column", show (column_ - 1), file] "" + Ext.Common.c_ "open" ["-na", "IntelliJ IDEA CE.app", "--args", "--line", show row, "--column", show (column - 1), file] "" ) , detectEditor "intellij" (Dir.doesDirectoryExist "/Applications/IntelliJ IDEA.app") (\file row column -> do - let column_ :: Int = column & readMaybeText & withDefault 1 -- IntelliJ seems to number it's columns from 1 index - Ext.Common.execCombineStdOutErr "open" ["-na", "IntelliJ IDEA.app", "--args", "--line", T.unpack row, "--column", show (column_ - 1), file] "" + Ext.Common.c_ "open" ["-na", "IntelliJ IDEA.app", "--args", "--line", show row, "--column", show (column - 1), file] "" ) ] @@ -742,6 +746,14 @@ logger = atomicPutStrLn $ T.unpack $ TE.decodeUtf8 bs ) + +noContentResponse :: Snap () +noContentResponse = do + modifyResponse $ setResponseStatus 204 "No Content" + r <- getResponse + finishWith r + + jsonResponse :: B.Builder -> Snap () jsonResponse s = do modifyResponse $ setContentType "application/json; charset=utf-8" @@ -779,11 +791,11 @@ error503 s = r <- getResponse finishWith r -error400 :: B.Builder -> Snap () -error400 s = +error400PlainText :: B.Builder -> Snap () +error400PlainText s = do modifyResponse $ setResponseStatus 400 "Bad Request" - modifyResponse $ setContentType "application/json; charset=utf-8" - writeBuilder $ "{\"error\":\"" <> s <> "\"}" + modifyResponse $ setContentType "text/plain; charset=utf-8" + writeBuilder s r <- getResponse finishWith r diff --git a/extra/Lamdera/String.hs b/extra/Lamdera/String.hs new file mode 100644 index 000000000..59b4f552e --- /dev/null +++ b/extra/Lamdera/String.hs @@ -0,0 +1,23 @@ +module Lamdera.String (fromChars) where + +import qualified Data.Utf8 as Utf8 +import qualified Elm.String as ES + + +fromChars :: [Char] -> ES.String +fromChars = + Utf8.fromChars . escape + + +escape :: [Char] -> [Char] +escape = + foldr + (\c acc -> + case c of + '\\' -> '\\' : '\\' : acc + '\'' -> '\\' : '\'' : acc + '\n' -> '\\' : 'n' : acc + '\r' -> '\\' : 'r' : acc + _ -> c : acc + ) + [] diff --git a/extra/Lamdera/UiSourceMap.hs b/extra/Lamdera/UiSourceMap.hs index 3ed4e4faf..1131e8646 100644 --- a/extra/Lamdera/UiSourceMap.hs +++ b/extra/Lamdera/UiSourceMap.hs @@ -3,7 +3,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} module Lamdera.UiSourceMap - (updateDecls, src) + (updateDecls, src, openEditorSrc) where import qualified Data.Map as Map @@ -13,7 +13,6 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import NeatInterpolation -import qualified Data.Utf8 import AST.Canonical import Elm.Package import qualified AST.Canonical as Can @@ -22,25 +21,31 @@ import qualified Reporting.Annotation import qualified Data.ByteString.Builder as B import Lamdera -import StandaloneInstances +import StandaloneInstances() +import qualified Elm.String as ES +import qualified Data.List as List +import qualified Lamdera.String -updateDecls :: Module.Canonical -> Can.Decls -> Can.Decls -updateDecls fileName decls = - case fileName of +updateDecls :: FilePath -> Module.Canonical -> Can.Decls -> Can.Decls +updateDecls fileName moduleName decls = + case moduleName of Module.Canonical (Name "author" "project") "Lamdera.Live" -> decls + Module.Canonical (Name "author" "project") "Lamdera.Repl" -> + decls + Module.Canonical (Name "author" "project") _ -> case decls of Can.Declare def nextDecl -> - Can.Declare (updateDefs fileName def) (updateDecls fileName nextDecl) + Can.Declare (updateDefs fileName moduleName def) (updateDecls fileName moduleName nextDecl) Can.DeclareRec def remainingDefs nextDecl -> Can.DeclareRec - (updateDefs fileName def) - (map (updateDefs fileName) remainingDefs) - (updateDecls fileName nextDecl) + (updateDefs fileName moduleName def) + (map (updateDefs fileName moduleName) remainingDefs) + (updateDecls fileName moduleName nextDecl) Can.SaveTheEnvironment -> Can.SaveTheEnvironment @@ -52,109 +57,110 @@ updateDecls fileName decls = newAttributes :: Bool + -> FilePath -> Module.Canonical -> Name.Name -> Reporting.Annotation.Region -> Expr -> Reporting.Annotation.Located Expr_ -newAttributes isElmUi fileName functionName location originalAttributes = +newAttributes isElmUi fileName moduleName functionName location originalAttributes = let a = Reporting.Annotation.At location in - (a (Call - (a (VarForeign - (Module.Canonical (Name "elm" "core") "List") - "append" - (Forall - (Map.fromList [("a", ())]) - (TLambda - (TType (Module.Canonical (Name "elm" "core") "List") "List" [TVar "a"]) - (TLambda - (TType (Module.Canonical (Name "elm" "core") "List") "List" [TVar "a"]) - (TType (Module.Canonical (Name "elm" "core") "List") "List" [TVar "a"])))))) - [ updateExpr fileName functionName originalAttributes - , newAttributesHelper isElmUi fileName functionName location - ])) - - -moduleToFilePath :: Module.Canonical -> String -moduleToFilePath ((Module.Canonical pkg moduleName)) = - moduleName & Name.toText & T.replace "." "/" & (\v -> v <> ".elm") & T.unpack - - -newAttributesHelper :: Bool -> Module.Canonical -> Name.Name -> Reporting.Annotation.Region -> Can.Expr -newAttributesHelper isElmUi module_ functionName location = + a (Binop + "::" + (Module.Canonical (Name "elm" "core") "List") + "cons" + (Forall + (Map.fromList [("a", ())]) + (TLambda + (TVar "a") + (TLambda + (TType (Module.Canonical (Name "elm" "core") "List") "List" [TVar "a"]) + (TType (Module.Canonical (Name "elm" "core") "List") "List" [TVar "a"])))) + (newProperty isElmUi fileName moduleName functionName location) + (updateExpr fileName moduleName functionName originalAttributes)) + + +propertyName :: ES.String +propertyName = + "lamderaSource" + + +propertyNameText :: Text +propertyNameText = + T.pack (ES.toChars propertyName) + + +newProperty :: Bool -> FilePath -> Module.Canonical -> Name.Name -> Reporting.Annotation.Region -> Can.Expr +newProperty isElmUi fileName (Module.Canonical _ moduleName) functionName location = let (Reporting.Annotation.Region (Reporting.Annotation.Position row column) _) = location - lineNumber = - Name.toChars functionName - ++ "," ++ (moduleToFilePath module_) - ++ ":" ++ show row - ++ ":" ++ show column - - & Data.Utf8.fromChars + propertyValue = + [ Name.toChars moduleName + , Name.toChars functionName + , show row + , show column + , fileName + ] + & List.intercalate "," + & Lamdera.String.fromChars a = Reporting.Annotation.At location - in - if isElmUi then - (a (List - [ (a (Call - (a (VarForeign - (Module.Canonical (Name "mdgriffith" "elm-ui") "Element") - "htmlAttribute" - (Forall - (Map.fromList [("msg", ())]) - (TLambda - (TAlias - (Module.Canonical (Name "elm" "html") "Html") - "Attribute" - [("msg", TVar "msg")] - (Filled (TType (Module.Canonical (Name "elm" "virtual-dom") "VirtualDom") "Attribute" [TVar "msg"]))) - (TAlias - (Module.Canonical (Name "mdgriffith" "elm-ui") "Element") - "Attribute" - [("msg", TVar "msg")] - (Filled (TType (Module.Canonical (Name "mdgriffith" "elm-ui") "Internal.Model") "Attribute" [TUnit, TVar "msg"]))))))) - [ (a (Call - (a (VarForeign - (Module.Canonical (Name "elm" "html") "Html.Attributes") - "attribute" - (Forall - (Map.fromList [("msg", ())]) - (TLambda - (TType (Module.Canonical (Name "elm" "core") "String") "String" []) - (TLambda - (TType (Module.Canonical (Name "elm" "core") "String") "String" []) - (TAlias - (Module.Canonical (Name "elm" "html") "Html") - "Attribute" - [("msg", TVar "msg")] - (Filled (TType (Module.Canonical (Name "elm" "virtual-dom") "VirtualDom") "Attribute" [TVar "msg"])))))))) - [(a (Str "line-number-attribute")), (a (Str lineNumber))])) - ])) - ])) - else - (a (List - [ (a (Call + + propertyCall = + a (Call + (a (VarForeign + (Module.Canonical (Name "elm" "html") "Html.Attributes") + "property" + (Forall + (Map.fromList [("msg", ())]) + (TLambda + (TType (Module.Canonical (Name "elm" "core") "String") "String" []) + (TLambda + (TType (Module.Canonical (Name "elm" "json") "Json.Encode") "Value" []) + (TAlias + (Module.Canonical (Name "elm" "html") "Html") + "Attribute" + [("msg", TVar "msg")] + (Filled (TType (Module.Canonical (Name "elm" "virtual-dom") "VirtualDom") "Attribute" [TVar "msg"])))))))) + [ a (Str propertyName) + , a (Call (a (VarForeign - (Module.Canonical (Name "elm" "html") "Html.Attributes") - "attribute" + (Module.Canonical (Name "elm" "json") "Json.Encode") + "string" (Forall - (Map.fromList [("msg", ())]) + Map.empty (TLambda (TType (Module.Canonical (Name "elm" "core") "String") "String" []) - (TLambda - (TType (Module.Canonical (Name "elm" "core") "String") "String" []) - (TAlias - (Module.Canonical (Name "elm" "html") "Html") - "Attribute" - [("msg", TVar "msg")] - (Filled (TType (Module.Canonical (Name "elm" "virtual-dom") "VirtualDom") "Attribute" [TVar "msg"])))))))) - [(a (Str "line-number-attribute")), (a (Str lineNumber))])) - ])) + (TType (Module.Canonical (Name "elm" "json") "Json.Encode") "Value" []))))) + [a (Str propertyValue)]) + ]) + in + if isElmUi then + a (Call + (a (VarForeign + (Module.Canonical (Name "mdgriffith" "elm-ui") "Element") + "htmlAttribute" + (Forall + (Map.fromList [("msg", ())]) + (TLambda + (TAlias + (Module.Canonical (Name "elm" "html") "Html") + "Attribute" + [("msg", TVar "msg")] + (Filled (TType (Module.Canonical (Name "elm" "virtual-dom") "VirtualDom") "Attribute" [TVar "msg"]))) + (TAlias + (Module.Canonical (Name "mdgriffith" "elm-ui") "Element") + "Attribute" + [("msg", TVar "msg")] + (Filled (TType (Module.Canonical (Name "mdgriffith" "elm-ui") "Internal.Model") "Attribute" [TUnit, TVar "msg"]))))))) + [ propertyCall ]) + else + propertyCall htmlNodes :: Set.Set Name.Name htmlNodes = @@ -257,8 +263,8 @@ htmlNodes = , "menu" ] -updateExpr :: Module.Canonical -> Name.Name -> Can.Expr -> Can.Expr -updateExpr fileName functionName (Reporting.Annotation.At location_ expr_) = +updateExpr :: FilePath -> Module.Canonical -> Name.Name -> Can.Expr -> Can.Expr +updateExpr fileName moduleName functionName (Reporting.Annotation.At location_ expr_) = (case expr_ of Can.VarLocal name -> Can.VarLocal name @@ -294,22 +300,22 @@ updateExpr fileName functionName (Reporting.Annotation.At location_ expr_) = Can.Float float Can.List exprs -> - Can.List (fmap (updateExpr fileName functionName) exprs) + Can.List (fmap (updateExpr fileName moduleName functionName) exprs) Can.Negate expr -> - Can.Negate ((updateExpr fileName functionName) expr) + Can.Negate (updateExpr fileName moduleName functionName expr) Can.Binop name canonical name2 annotation expr expr2 -> - Can.Binop name canonical name2 annotation ((updateExpr fileName functionName) expr) ((updateExpr fileName functionName) expr2) + Can.Binop name canonical name2 annotation (updateExpr fileName moduleName functionName expr) (updateExpr fileName moduleName functionName expr2) Can.Lambda patterns expr -> - Can.Lambda patterns ((updateExpr fileName functionName) expr) + Can.Lambda patterns (updateExpr fileName moduleName functionName expr) Can.Call (Reporting.Annotation.At location (Can.VarForeign - (Module.Canonical (Name "elm" "html") moduleName) + (Module.Canonical (Name "elm" "html") htmlModuleName) functionName_ annotation ) @@ -317,30 +323,29 @@ updateExpr fileName functionName (Reporting.Annotation.At location_ expr_) = (firstParam : rest) -> let expr = - (Reporting.Annotation.At + Reporting.Annotation.At location (Can.VarForeign - (Module.Canonical (Name "elm" "html") moduleName) + (Module.Canonical (Name "elm" "html") htmlModuleName) functionName_ annotation ) - ) in - if Set.member functionName_ htmlNodes && moduleName == "Html" then + if Set.member functionName_ htmlNodes && htmlModuleName == "Html" then Can.Call expr - (newAttributes False fileName functionName location firstParam - : fmap (updateExpr fileName functionName) rest) + (newAttributes False fileName moduleName functionName location firstParam + : fmap (updateExpr fileName moduleName functionName) rest) else Can.Call - ((updateExpr fileName functionName) expr) - (fmap (updateExpr fileName functionName) (firstParam : rest)) + (updateExpr fileName moduleName functionName expr) + (fmap (updateExpr fileName moduleName functionName) (firstParam : rest)) Can.Call (Reporting.Annotation.At location (Can.VarForeign - (Module.Canonical (Name "mdgriffith" "elm-ui") moduleName) + (Module.Canonical (Name "mdgriffith" "elm-ui") elmUiModuleName) functionName_ annotation ) @@ -348,14 +353,13 @@ updateExpr fileName functionName (Reporting.Annotation.At location_ expr_) = (firstParam : rest) -> let expr = - (Reporting.Annotation.At + Reporting.Annotation.At location (Can.VarForeign - (Module.Canonical (Name "mdgriffith" "elm-ui") moduleName) + (Module.Canonical (Name "mdgriffith" "elm-ui") elmUiModuleName) functionName_ annotation ) - ) isElement = (functionName_ == "el" @@ -372,14 +376,14 @@ updateExpr fileName functionName (Reporting.Annotation.At location_ expr_) = || functionName_ == "downloadAs" || functionName_ == "image" ) - && moduleName == "Element" + && elmUiModuleName == "Element" isKeyed = (functionName_ == "el" || functionName_ == "row" || functionName_ == "column" ) - && moduleName == "Element.Keyed" + && elmUiModuleName == "Element.Keyed" isInput = (functionName_ == "button" @@ -396,55 +400,55 @@ updateExpr fileName functionName (Reporting.Annotation.At location_ expr_) = || functionName_ == "radio" || functionName_ == "radioRow" ) - && moduleName == "Element.Input" + && elmUiModuleName == "Element.Input" in if isElement || isKeyed || isInput then Can.Call expr - (newAttributes True fileName functionName location firstParam - : fmap (updateExpr fileName functionName) rest) + (newAttributes True fileName moduleName functionName location firstParam + : fmap (updateExpr fileName moduleName functionName) rest) else Can.Call - ((updateExpr fileName functionName) expr) - (fmap (updateExpr fileName functionName) (firstParam : rest)) + (updateExpr fileName moduleName functionName expr) + (fmap (updateExpr fileName moduleName functionName) (firstParam : rest)) Can.Call expr exprs -> - Can.Call ((updateExpr fileName functionName) expr) (fmap (updateExpr fileName functionName) exprs) + Can.Call (updateExpr fileName moduleName functionName expr) (fmap (updateExpr fileName moduleName functionName) exprs) Can.If exprs expr -> Can.If (fmap (\(first, second) -> - ((updateExpr fileName functionName) first - , (updateExpr fileName functionName) second + ( updateExpr fileName moduleName functionName first + , updateExpr fileName moduleName functionName second ) ) exprs ) - ((updateExpr fileName functionName) expr) + (updateExpr fileName moduleName functionName expr) Can.Let def expr -> Can.Let - (updateDefs fileName def) - ((updateExpr fileName functionName) expr) + (updateDefs fileName moduleName def) + (updateExpr fileName moduleName functionName expr) Can.LetRec defs expr -> Can.LetRec - (fmap (updateDefs fileName) defs) - ((updateExpr fileName functionName) expr) + (fmap (updateDefs fileName moduleName) defs) + (updateExpr fileName moduleName functionName expr) Can.LetDestruct pattern expr expr2 -> Can.LetDestruct pattern - ((updateExpr fileName functionName) expr) - ((updateExpr fileName functionName) expr2) + (updateExpr fileName moduleName functionName expr) + (updateExpr fileName moduleName functionName expr2) Can.Case expr caseBranches -> Can.Case - ((updateExpr fileName functionName) expr) + (updateExpr fileName moduleName functionName expr) (fmap (\(Can.CaseBranch pattern caseExpr) -> - Can.CaseBranch pattern ((updateExpr fileName functionName) caseExpr) + Can.CaseBranch pattern (updateExpr fileName moduleName functionName caseExpr) ) caseBranches ) @@ -453,102 +457,100 @@ updateExpr fileName functionName (Reporting.Annotation.At location_ expr_) = Can.Accessor name Can.Access expr name -> - Can.Access ((updateExpr fileName functionName) expr) name + Can.Access (updateExpr fileName moduleName functionName expr) name Can.Update name expr fieldUpdates -> Can.Update name - ((updateExpr fileName functionName) expr) + (updateExpr fileName moduleName functionName expr) (fmap (\(Can.FieldUpdate region expr__) -> - Can.FieldUpdate region (updateExpr fileName functionName expr__) + Can.FieldUpdate region (updateExpr fileName moduleName functionName expr__) ) fieldUpdates ) Can.Record fields -> - Can.Record (fmap (\field -> updateExpr fileName functionName field) fields) + Can.Record (fmap (updateExpr fileName moduleName functionName) fields) Can.Unit -> Can.Unit Can.Tuple expr expr2 maybeExpr -> Can.Tuple - ((updateExpr fileName functionName) expr) - ((updateExpr fileName functionName) expr2) - (fmap (updateExpr fileName functionName) maybeExpr) + (updateExpr fileName moduleName functionName expr) + (updateExpr fileName moduleName functionName expr2) + (fmap (updateExpr fileName moduleName functionName) maybeExpr) Can.Shader shaderSource shaderTypes -> Can.Shader shaderSource shaderTypes ) & Reporting.Annotation.At location_ -updateDefs :: Module.Canonical -> Can.Def -> Can.Def -updateDefs fileName def = +updateDefs :: FilePath -> Module.Canonical -> Can.Def -> Can.Def +updateDefs fileName moduleName def = case def of Can.Def name patterns expr -> Can.Def name patterns - ((updateExpr fileName (Reporting.Annotation.toValue name)) expr) + (updateExpr fileName moduleName (Reporting.Annotation.toValue name) expr) Can.TypedDef name freeVars patterns expr type_ -> Can.TypedDef name freeVars patterns - ((updateExpr fileName (Reporting.Annotation.toValue name)) expr) + (updateExpr fileName moduleName (Reporting.Annotation.toValue name) expr) type_ -{-|123 is used as a suffix to reduce the chances of a name collision-} src :: B.Builder src = [text| - -var mouseX123 = 0; -var mouseY123 = 0; -var backgroundDiv123 = null; -function getNodesWithLineNumber123(node) { - let list = []; - if (node.parentNode) { - list = getNodesWithLineNumber123(node.parentNode); - } - if (node.attributes) { - let attribute = node.attributes.getNamedItem("line-number-attribute"); - if (attribute) { - let components = attribute.value.split(","); - return [{ functionName : components[0], path: components[1] }].concat(list); - } - } - return list; +;(function() { +var propertyName = "$propertyNameText"; +var mouseX = 0; +var mouseY = 0; +var backgroundDiv = null; +function getNodesWithLineNumber(targets) { + return targets + .map(target => { + let property = target[propertyName]; + if (property === undefined) { + return null; + } + let [moduleName, functionName, row, column, ...fileName] = property.split(","); + return {fileName: fileName.join(","), moduleName, functionName, row, column}; + }) + .filter(Boolean); } window.addEventListener( "mousemove", function (event) { - mouseX123 = event.clientX; - mouseY123 = event.clientY; + mouseX = event.clientX; + mouseY = event.clientY; }); window.addEventListener( "keydown", function(event) { - if (event.ctrlKey && event.altKey && event.keyCode == 88) + if (event.ctrlKey && event.altKey && event.keyCode == 88) // x { - let target = document.elementFromPoint(mouseX123, mouseY123); - let nodes = getNodesWithLineNumber123(target); + let targets = document.elementsFromPoint(mouseX, mouseY); + let nodes = getNodesWithLineNumber(targets); if (nodes.length > 0) { - if (backgroundDiv123) { backgroundDiv123.remove(); } + if (backgroundDiv) { backgroundDiv.remove(); } - backgroundDiv123 = document.createElement("div"); - backgroundDiv123.style.setProperty("left", "0px", "important"); - backgroundDiv123.style.setProperty("top", "0px", "important"); - backgroundDiv123.style.setProperty("position", "fixed", "important"); - backgroundDiv123.style.setProperty("width", "100%", "important"); - backgroundDiv123.style.setProperty("height", "100%", "important"); - backgroundDiv123.onclick = function() { backgroundDiv123.remove(); }; + backgroundDiv = document.createElement("div"); + backgroundDiv.style.setProperty("left", "0px", "important"); + backgroundDiv.style.setProperty("top", "0px", "important"); + backgroundDiv.style.setProperty("position", "fixed", "important"); + backgroundDiv.style.setProperty("width", "100%", "important"); + backgroundDiv.style.setProperty("height", "100%", "important"); + backgroundDiv.onclick = function() { backgroundDiv.remove(); }; let div = document.createElement("div"); div.style.setProperty("position", "absolute", "important"); @@ -562,10 +564,8 @@ window.addEventListener( div.style.setProperty("font-family", 'system-ui, "Helvetica Neue", sans-serif', "important"); nodes.forEach(node => { - let splitPath = node.path.split(":"); - let moduleName = splitPath[0].substring(0,splitPath[0].length-3); let button = document.createElement("button"); - button.textContent = moduleName + node.functionName + ":" + splitPath[1]; + button.textContent = node.moduleName + "." + node.functionName + ":" + node.row; button.style.setProperty("padding", "4px", "important"); button.style.setProperty("text-align", "right", "important"); button.style.setProperty("border", "none", "important"); @@ -574,22 +574,33 @@ window.addEventListener( button.addEventListener("mouseenter", function(){ this.style.setProperty("background", "rgb(65, 65, 65)", "important") }); button.addEventListener("mouseleave", function(){ this.style.setProperty("background", "rgb(46, 51, 53)", "important") }); button.onclick = function() { - backgroundDiv123.remove(); - let xmlHttpReq = new XMLHttpRequest(); - xmlHttpReq.open("GET", "/_x/editor/src/" + node.path, true); - xmlHttpReq.send(null); + backgroundDiv.remove(); + $openEditorSrc }; div.appendChild(button); }); - backgroundDiv123.appendChild(div); - document.body.appendChild(backgroundDiv123); + backgroundDiv.appendChild(div); + document.body.appendChild(backgroundDiv); - div.style.setProperty("left", Math.min(mouseX123, window.innerWidth - div.offsetWidth) + "px", "important"); - div.style.setProperty("top", Math.min(mouseY123, window.innerHeight - div.offsetHeight) + "px", "important"); + div.style.setProperty("left", Math.min(mouseX, window.innerWidth - div.offsetWidth) + "px", "important"); + div.style.setProperty("top", Math.min(mouseY, window.innerHeight - div.offsetHeight) + "px", "important"); } } }); - +}()); |] & T.encodeUtf8Builder + + +openEditorSrc :: Text +openEditorSrc = + [text| +let url = new URL("/_x/editor/", window.top.location); +url.pathname += node.fileName; +url.searchParams.append("row", node.row); +url.searchParams.append("column", node.column); +fetch(url) + .then(response => response.ok ? undefined : response.text().then(message => alert(message))) + .catch(error => alert(error.message)); + |] diff --git a/reactor/src/Errors.elm b/reactor/src/Errors.elm index 21b148907..22c1e580a 100644 --- a/reactor/src/Errors.elm +++ b/reactor/src/Errors.elm @@ -1,33 +1,45 @@ -module Errors exposing (main) +-- @LAMDERA: Added `jumpTo` from `worker/src/Errors.elm` and adapted it for Lamdera. +port module Errors exposing (main) import Browser import Char import Html exposing (..) import Html.Attributes exposing (..) +import Html.Events exposing (onClick) import String import Json.Decode as D import Elm.Error as Error +-- PORTS + + +port jumpTo : { fileName : String, row : Int, column : Int } -> Cmd msg + + + -- MAIN main = Browser.document { init = \flags -> (D.decodeValue Error.decoder flags, Cmd.none) - , update = \_ exit -> (exit, Cmd.none) + , update = \(filePath, region) result -> (result, jumpTo { fileName = filePath, row = region.start.line, column = region.start.column }) , view = view , subscriptions = \_ -> Sub.none } +type alias Msg = (String, Error.Region) + + -- VIEW -view : Result D.Error Error.Error -> Browser.Document msg +view : Result D.Error Error.Error -> Browser.Document Msg view result = { title = "Problem!" , body = @@ -40,7 +52,7 @@ view result = } -viewError : Error.Error -> Html msg +viewError : Error.Error -> Html Msg viewError error = div [ style "width" "100%" @@ -65,11 +77,11 @@ viewError error = ] -viewErrorHelp : Error.Error -> List (Html msg) +viewErrorHelp : Error.Error -> List (Html Msg) viewErrorHelp error = case error of Error.GeneralProblem { path, title, message } -> - viewHeader title path :: viewMessage message + viewHeader title path Nothing :: viewMessage message Error.ModuleProblems badModules -> viewBadModules badModules @@ -79,30 +91,54 @@ viewErrorHelp error = -- VIEW HEADER -viewHeader : String -> Maybe String -> Html msg -viewHeader title maybeFilePath = +viewHeader : String -> Maybe String -> Maybe Error.Region -> Html Msg +viewHeader title maybeFilePath maybeRegion = let left = "-- " ++ title ++ " " - right = - case maybeFilePath of - Nothing -> - "" - Just filePath -> - " " ++ filePath - in - span [ style "color" "rgb(51,187,200)" ] [ text (fill left right ++ "\n\n") ] - -fill : String -> String -> String -fill left right = - left ++ String.repeat (80 - String.length left - String.length right) "-" ++ right + (rightLength, rightElements) = + case (maybeFilePath, maybeRegion) of + (Just filePath, Nothing) -> + let + fullText = + " " ++ filePath + in + ( String.length fullText + , [text fullText] + ) + + (Just filePath, Just region) -> + let + fullText = + filePath ++ ":" ++ String.fromInt region.start.line ++ ":" ++ String.fromInt region.start.column + in + ( 1 + String.length fullText + , [ text " " + , span + [ style "cursor" "pointer" + , style "text-decoration" "underline" + , onClick (filePath, region) + ] + [ text fullText ] + + ] + ) + + _ -> + (0, []) + in + span [ style "color" "rgb(51,187,200)" ] + ( text (left ++ String.repeat (80 - String.length left - rightLength) "-") + :: rightElements + ++ [ text "\n\n" ] + ) -- VIEW BAD MODULES -viewBadModules : List Error.BadModule -> List (Html msg) +viewBadModules : List Error.BadModule -> List (Html Msg) viewBadModules badModules = case badModules of [] -> @@ -115,14 +151,14 @@ viewBadModules badModules = viewBadModule a :: viewSeparator a.name b.name :: viewBadModules (b :: cs) -viewBadModule : Error.BadModule -> Html msg +viewBadModule : Error.BadModule -> Html Msg viewBadModule { path, problems } = span [] (List.map (viewProblem path) problems) -viewProblem : String -> Error.Problem -> Html msg +viewProblem : String -> Error.Problem -> Html Msg viewProblem filePath problem = - span [] (viewHeader problem.title (Just filePath) :: viewMessage problem.message) + span [] (viewHeader problem.title (Just filePath) (Just problem.region) :: viewMessage problem.message) viewSeparator : String -> String -> Html msg diff --git a/terminal/src/Develop.hs b/terminal/src/Develop.hs index d32a5da4e..9d45db64d 100644 --- a/terminal/src/Develop.hs +++ b/terminal/src/Develop.hs @@ -54,6 +54,8 @@ import qualified Ext.Sentry as Sentry import Control.Concurrent.STM (atomically, newTVarIO, readTVar, writeTVar, TVar) import StandaloneInstances +import qualified Reporting.Exit.Help as Help +import qualified Reporting.Error as Error -- RUN THE DEV SERVER @@ -272,7 +274,22 @@ compileToBuilder path = -- debugging in these scenarios, as the browser will just get zero bytes -- debugPass "serveElm error" (Exit.reactorToReport exit) (pure ()) Help.makePageHtml "Errors" $ Just $ - Exit.toJson $ Exit.reactorToReport exit + Exit.toJson $ relativeErrorFilePaths $ Exit.reactorToReport exit + + +relativeErrorFilePaths :: Help.Report -> Help.Report +relativeErrorFilePaths report = + case report of + Help.CompilerReport root e es -> + Help.CompilerReport root (relativeErrorFilePath root e) (fmap (relativeErrorFilePath root) es) + + Help.Report {} -> + report + + +relativeErrorFilePath :: FilePath -> Error.Module -> Error.Module +relativeErrorFilePath root (Error.Module name absolutePath modificationTime source error) = + Error.Module name (FP.makeRelative root absolutePath) modificationTime source error serveElm_ :: FilePath -> FilePath -> Snap () diff --git a/terminal/src/Develop/Generate/Help.hs b/terminal/src/Develop/Generate/Help.hs index 985c62aec..29050eda9 100644 --- a/terminal/src/Develop/Generate/Help.hs +++ b/terminal/src/Develop/Generate/Help.hs @@ -17,6 +17,7 @@ import qualified Json.Encode as Encode import qualified Lamdera.Live import qualified Lamdera.UiSourceMap +import qualified Data.Text.Encoding as T -- PAGES @@ -33,7 +34,9 @@ makePageHtml moduleName maybeFlags =