-
Notifications
You must be signed in to change notification settings - Fork 9
Repl API #10
New issue
Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.
By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.
Already on GitHub? Sign in to your account
Open
supermario
wants to merge
35
commits into
lamdera-next
Choose a base branch
from
elm-notebook-repl
base: lamdera-next
Could not load branches
Branch not found: {{ refName }}
Loading
Could not load tags
Nothing to show
Loading
Are you sure you want to change the base?
Some commits from the old base branch may be removed from the timeline,
and old review comments may become outdated.
+668
−1
Open
Repl API #10
Changes from all commits
Commits
Show all changes
35 commits
Select commit
Hold shift + click to select a range
d8ae362
llvm@13 fixes local M1 build, try on buildserver
supermario 15a7069
Patch in repl API functionality for elm-notebook exploration
supermario c097d3e
change alllowed origins to http://localhost:8007 only
jxxcarlson b2a2e56
Exclude Jim's experimental files
jxxcarlson e0d55f0
Change Test.hs so as to talk to elm-notebook
jxxcarlson 7c8f310
Add debug statements
jxxcarlson 8290dee
Added: '_ -> error $ "unreachable:" ++ show e' to function 'watch'. …
jxxcarlson fa3cfe3
I am committing this, but I can't see what has changed.
jxxcarlson 441f1ce
Add elm-community/list-extra to outlines/repl/elm.json
jxxcarlson a27d4bb
Remove duplicate elm.json entries
jxxcarlson d591f19
Add module Endpoint.Package from extra/, (2) Chane Develop (in termin…
jxxcarlson d1d0cd9
Fix path for writing the elm.json file
jxxcarlson 92c1c80
Fix stray space in word "dependencies"
jxxcarlson 1e775be
Add type ElmPackage and decoder for it.
jxxcarlson 9e57721
Return outlines/repl/elm.json to its original state
jxxcarlson c9af64d
Introduced a deterministic delay for executing Notebook.Package.nowSe…
jxxcarlson 87727e6
When packages are added to elm.json, report to the client how many we…
jxxcarlson e544b92
Draft 1
jxxcarlson 48def3e
Draft 2
jxxcarlson 3391d5f
Fix JSON output
jxxcarlson b727101
Implement dynamic loading of packages submitted to the Elm compiler.
jxxcarlson 8046918
Return outlines/repl/elm.json to its original state
jxxcarlson 3935f9d
fix but in properly computng evalstate before compilation.
jxxcarlson effbe40
Add debug code to Endpoint/Repl.hs
jxxcarlson 8a8a994
Add 'compiler.iml' to .gitignore
jxxcarlson bdf9ffc
Return to previous working state
jxxcarlson 7d4f078
add back extra/Artifacts.hs
jxxcarlson be46c86
Restore elm.json to original state
jxxcarlson ac87fe8
Renamed: extra/Artifacts.hs -> extra/ReplArtifacts.hs
jxxcarlson dc1fbe5
Add comment explaining the purpose of module Package
jxxcarlson b422951
Add comments to explain the purpose and operation of extra/Endpoint/P…
jxxcarlson 14b46e6
More comments
jxxcarlson 20bb71e
Comments for ReplArtifacts
jxxcarlson 9173633
Add clause 'Types.OnConnected sessionId clientId' to Backend.update:
jxxcarlson 1505d77
Merge branch 'lamdera-next' into elm-notebook-repl
supermario File filter
Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
There are no files selected for viewing
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
|
@@ -17,3 +17,7 @@ extra/.cache | |
# @TESTS | ||
elm-home | ||
|
||
# Jim | ||
experimental/ | ||
.vscode/ | ||
compiler.iml |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,48 @@ | ||
{-# OPTIONS_GHC -Wall #-} | ||
module Cors | ||
( allow | ||
) | ||
where | ||
|
||
|
||
import qualified Data.HashSet as HashSet | ||
import Network.URI (parseURI) | ||
import Snap.Core (Snap, Method, method) | ||
import Snap.Util.CORS (CORSOptions(..), HashableMethod(..), OriginList(Origins), applyCORS, mkOriginSet) | ||
|
||
|
||
|
||
-- ALLOW | ||
|
||
|
||
allow :: Method -> [String] -> Snap () -> Snap () | ||
allow method_ origins snap = | ||
applyCORS (toOptions method_ origins) $ method method_ $ | ||
snap | ||
|
||
|
||
|
||
-- TO OPTIONS | ||
|
||
|
||
toOptions :: (Monad m) => Method -> [String] -> CORSOptions m | ||
toOptions method_ origins = | ||
let | ||
allowedOrigins = toOriginList origins | ||
allowedMethods = HashSet.singleton (HashableMethod method_) | ||
in | ||
CORSOptions | ||
{ corsAllowOrigin = return allowedOrigins | ||
, corsAllowCredentials = return True | ||
, corsExposeHeaders = return HashSet.empty | ||
, corsAllowedMethods = return allowedMethods | ||
, corsAllowedHeaders = return | ||
} | ||
|
||
|
||
toOriginList :: [String] -> OriginList | ||
toOriginList origins = | ||
Origins $ mkOriginSet $ | ||
case traverse parseURI origins of | ||
Just uris -> uris | ||
Nothing -> error "invalid entry given to toOriginList list" |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,126 @@ | ||
{-# LANGUAGE OverloadedStrings #-} | ||
{-# LANGUAGE DeriveGeneric #-} | ||
|
||
module Endpoint.Package (handlePost, reportOnInstalledPackages) where | ||
|
||
{- | ||
1. | ||
|
||
This endpoint will respond to POST requests to "https://repl.lamdera.com/packageList" | ||
with a JSON body of the form: | ||
[ | ||
{ "name": "elm/core", "version": "1.0.5" }, | ||
{ "name": "elm/html", "version": "1.0.0" } | ||
] | ||
It will write an elm.json file to the repl directory, and then reload the repl. | ||
This response is mediate by function `handlePost` below. | ||
|
||
2. | ||
|
||
In additon, this endpoint will respond to GET requests to "https://repl.lamdera.com/reportOnInstalledPackages" | ||
with a JSON body of the form: | ||
[ | ||
{ "name": "elm/core", "version": "1.0.5" }, | ||
{ "name": "elm/html", "version": "1.0.0" } | ||
] | ||
The json body reports on the packages that are currently installed in the repl. | ||
This response is mediated by function `reportOnInstalledPackages` below. | ||
|
||
NOTE. handlePost and reportOnInstalledPackages | ||
are referenced in the Snap webserver at Develop.runWithRoot | ||
via the code fragments | ||
|
||
SnapCore.path "packageList" $ Package.handlePost artifactRef) | ||
SnapCore.path "reportOnInstalledPackages" $ Package.reportOnInstalledPackages) | ||
-} | ||
|
||
|
||
import GHC.Generics (Generic) | ||
import Snap.Core | ||
import Snap.Http.Server | ||
import Data.Aeson (FromJSON, eitherDecode, encode, ToJSON, toJSON, object, (.=)) | ||
import Data.ByteString (ByteString) | ||
import Data.ByteString.Lazy (toStrict) | ||
import qualified Data.ByteString.Lazy.Char8 as BL | ||
import qualified Data.ByteString.Char8 as ByteString | ||
import GHC.Generics | ||
import System.IO (writeFile) | ||
import Control.Monad.IO.Class (liftIO) | ||
import qualified Data.Map as Map | ||
--- | ||
import Snap.Util.FileServe | ||
import qualified Data.ByteString.Lazy as LBS | ||
import qualified Data.HashMap.Strict as HM | ||
import Data.Text.Encoding (decodeUtf8) | ||
import Snap.Http.Server.Config (setPort, defaultConfig) | ||
import qualified ReplArtifacts | ||
import Data.IORef | ||
|
||
|
||
data Package = Package { name :: String, version :: String } deriving (Show, Generic) | ||
|
||
instance FromJSON Package | ||
instance ToJSON Package | ||
|
||
|
||
type PackageList = [Package] | ||
|
||
writeElmJson :: PackageList -> IO () | ||
writeElmJson pkgs = do | ||
let directDeps = Map.fromList $ ("elm/core", "1.0.5"):[(name p, version p) | p <- pkgs] | ||
elmJson = object [ | ||
"type" .= ("application" :: String), | ||
"source-directories" .= (["../../repl-src"] :: [String]), | ||
"elm-version" .= ("0.19.1" :: String), | ||
"dependencies" .= object [ | ||
"direct" .= directDeps, | ||
"indirect" .= object [ | ||
"elm/json" .= ("1.1.3" :: String) | ||
] | ||
], | ||
"test-dependencies" .= object [ | ||
"direct" .= (Map.empty :: Map.Map String String), | ||
"indirect" .= (Map.empty :: Map.Map String String) | ||
] | ||
] | ||
writeFile "./outlines/repl/elm.json" ( BL.unpack $ encode elmJson) | ||
|
||
|
||
handlePost :: IORef ReplArtifacts.Artifacts -> Snap () | ||
handlePost artifactRef = do | ||
body <- readRequestBody 10000 | ||
let maybePackageList = eitherDecode body :: Either String PackageList | ||
case maybePackageList of | ||
Left err -> writeBS $ "Error: Could not decode JSON: " <> (ByteString.pack err) | ||
Right packages -> do | ||
liftIO $ writeElmJson packages | ||
let message = ByteString.pack $ "Packages added: " ++ (show $ length packages) | ||
writeBS message | ||
newArtifacts <- liftIO ReplArtifacts.loadRepl | ||
liftIO $ writeIORef artifactRef newArtifacts | ||
|
||
|
||
|
||
data Dependencies = Dependencies { | ||
direct :: HM.HashMap String String | ||
} deriving (Generic, Show) | ||
|
||
data TopLevel = TopLevel { | ||
dependencies :: Dependencies | ||
} deriving (Generic, Show) | ||
|
||
instance FromJSON TopLevel | ||
|
||
instance FromJSON Dependencies | ||
|
||
--- curl -X POST -H "Content-Length: 0" http://localhost:8000/reportOnInstalledPackages | ||
|
||
reportOnInstalledPackages :: Snap () | ||
reportOnInstalledPackages = do | ||
jsonData <- liftIO $ LBS.readFile "./outlines/repl/elm.json" | ||
case eitherDecode jsonData :: Either String TopLevel of | ||
Left err -> writeBS $ "Failed to parse JSON: " <> (LBS.toStrict jsonData) | ||
Right topLevel -> do | ||
let directDeps = HM.toList $ direct $ dependencies topLevel | ||
let outputList = map (\(name, version) -> object ["name" .= name, "version" .= version]) directDeps | ||
writeBS . LBS.toStrict . encode $ outputList |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,304 @@ | ||
{-# OPTIONS_GHC -Wall #-} | ||
{-# LANGUAGE OverloadedStrings #-} | ||
module Endpoint.Repl | ||
( endpoint | ||
) | ||
where | ||
|
||
{- | ||
The purpose of this endpoint is to provide a REPL for Elm that | ||
is accessible via Http requests. The function `endpoint` of | ||
this module is referenced in the Snap webserver at Develop.runWithRoot | ||
via the code fragment | ||
SnapCore.path "repl" $ Repl.endpoint artifactRef | ||
Function decodeBodyHelp decodes incoming Json requests to the repl. | ||
The Json data has the form | ||
{ "imports": <dictionary of imports>, | ||
"types": <dictionary of types>, | ||
"decls": <dictionary of declarations>, | ||
"entry": <string> | ||
} | ||
where the dictionaries are of the form | ||
{ "name": <string>, "source": <string> } | ||
and "entry" the string representation of the Elm | ||
code to be evaluated. | ||
Here is a typical incoming json object from a request to | ||
evaluate `run (first int (symbol ".")) "42."`: | ||
entry: "run (first int (symbol \".\")) \"42.\"" | ||
imports: Dict.fromList [("Parser","import Parser exposing(..)\n")] | ||
decls: Dict.fromList [("first p q","first p q = p |> andThen (\s -> q |> map (\_ -> s))\n"))] | ||
types: Dict.fromList [] | ||
NOTES. | ||
1. Repl.endpoint defined here is called by the Snap server Develop.runWithRoot | ||
via the code fragment | ||
SnapCore.path "repl" $ Repl.endpoint artifactRef | ||
2. The value of of artifactRef is set by | ||
initialArtifacts <- ReplArtifacts.loadRepl | ||
in `Develop.runWithRoot`. | ||
3. If `endpoint artifactRef` successfully decodes the request, it | ||
passes the resulting information to | ||
toOutcome :: A.Artifacts -> Repl.State -> String -> Outcome | ||
which in turn passes the information to `compile`. The result | ||
of compilation is handed to `serveOutcome` which (at long last) | ||
replies to the client's request. | ||
-} | ||
|
||
import Data.Aeson ((.:)) | ||
import qualified Data.Aeson as Aeson | ||
import qualified Data.Aeson.Types as Aeson | ||
import qualified Data.ByteString as BS | ||
import qualified Data.ByteString.Builder as B | ||
import qualified Data.ByteString.Lazy as LBS | ||
import qualified Data.Map as Map | ||
import Data.Map ((!)) | ||
import qualified Data.Map.Utils as Map | ||
import qualified Data.Name as N | ||
import qualified Data.NonEmptyList as NE | ||
import Snap.Core | ||
import qualified ReplArtifacts as A | ||
import qualified Cors | ||
import qualified AST.Source as Src | ||
import qualified AST.Canonical as Can | ||
import qualified AST.Optimized as Opt | ||
import qualified Compile | ||
import qualified Elm.Interface as I | ||
import qualified Elm.ModuleName as ModuleName | ||
import qualified Elm.Package as Pkg | ||
import qualified File | ||
import qualified Generate.JavaScript as JS | ||
import qualified Json.Encode as Encode | ||
import qualified Parse.Module as Parse | ||
import qualified Repl | ||
import qualified Reporting.Annotation as A | ||
import qualified Reporting.Error as Error | ||
import qualified Reporting.Error.Import as Import | ||
import qualified Reporting.Exit as Exit | ||
import qualified Reporting.Exit.Help as Help | ||
import qualified Reporting.Render.Type.Localizer as L | ||
import Lamdera as LA | ||
import qualified Data.Text | ||
|
||
import Data.IORef | ||
|
||
|
||
-- ALLOWED ORIGINS | ||
|
||
|
||
allowedOrigins :: [String] | ||
allowedOrigins = | ||
[ "http://localhost:8007" | ||
] | ||
|
||
|
||
|
||
-- ENDPOINT | ||
|
||
|
||
endpoint :: IORef A.Artifacts -> Snap () | ||
endpoint artifactRef = | ||
Cors.allow POST allowedOrigins $ | ||
do currentArtifacts <- liftIO $ readIORef artifactRef | ||
body <- readRequestBody (64 * 1024) | ||
case decodeBody body of | ||
Just (state, entry) -> | ||
serveOutcome (toOutcome currentArtifacts state entry) | ||
|
||
Nothing -> | ||
do modifyResponse $ setResponseStatus 400 "Bad Request" | ||
modifyResponse $ setContentType "text/html; charset=utf-8" | ||
writeBS "Received unexpected JSON body." | ||
|
||
|
||
|
||
-- TO OUTCOME | ||
|
||
|
||
data Outcome | ||
= NewImport N.Name | ||
| NewType N.Name | ||
| NewWork B.Builder | ||
-- | ||
| Skip | ||
| Indent | ||
| DefStart N.Name | ||
-- | ||
| NoPorts | ||
| InvalidCommand | ||
| Failure BS.ByteString Error.Error | ||
|
||
|
||
toOutcome :: A.Artifacts -> Repl.State -> String -> Outcome | ||
toOutcome artifacts state entry = | ||
case reverse (lines entry) of | ||
[] -> | ||
Skip | ||
|
||
prev : rev -> | ||
case Repl.categorize (Repl.Lines prev rev) of | ||
Repl.Done input -> | ||
case input of | ||
Repl.Import name src -> compile artifacts state (ImportEntry name src) | ||
Repl.Type name src -> compile artifacts state (TypeEntry name src) | ||
Repl.Decl name src -> compile artifacts state (DeclEntry name src) | ||
Repl.Expr src -> compile artifacts state (ExprEntry src) | ||
Repl.Port -> NoPorts | ||
Repl.Skip -> Skip | ||
Repl.Reset -> InvalidCommand | ||
Repl.Exit -> InvalidCommand | ||
Repl.Help _ -> InvalidCommand | ||
|
||
Repl.Continue prefill -> | ||
case prefill of | ||
Repl.Indent -> Indent | ||
Repl.DefStart name -> DefStart name | ||
|
||
|
||
|
||
-- SERVE OUTCOME | ||
|
||
|
||
serveOutcome :: Outcome -> Snap () | ||
serveOutcome outcome = | ||
let | ||
serveString = serveBuilder "text/plain" | ||
in | ||
case outcome of | ||
NewImport name -> serveString $ "add-import:" <> N.toBuilder name | ||
NewType name -> serveString $ "add-type:" <> N.toBuilder name | ||
NewWork js -> serveBuilder "application/javascript" js | ||
Skip -> serveString $ "skip" | ||
Indent -> serveString $ "indent" | ||
DefStart name -> serveString $ "def-start:" <> N.toBuilder name | ||
NoPorts -> serveString $ "no-ports" | ||
InvalidCommand -> serveString $ "invalid-command" | ||
Failure source err -> | ||
serveBuilder "application/json" $ Encode.encodeUgly $ Exit.toJson $ | ||
Help.compilerReport "/" (Error.Module N.replModule "/repl" File.zeroTime source err) [] | ||
|
||
|
||
serveBuilder :: BS.ByteString -> B.Builder -> Snap () | ||
serveBuilder mime builder = | ||
do modifyResponse (setContentType mime) | ||
writeBuilder builder | ||
|
||
|
||
|
||
-- COMPILE | ||
|
||
|
||
data EntryType | ||
= ImportEntry N.Name BS.ByteString | ||
| TypeEntry N.Name BS.ByteString | ||
| DeclEntry N.Name BS.ByteString | ||
| ExprEntry BS.ByteString | ||
|
||
|
||
compile :: A.Artifacts -> Repl.State -> EntryType -> Outcome | ||
compile (A.Artifacts interfaces objects) state@(Repl.State imports types decls) entryType = | ||
let | ||
source = | ||
case entryType of | ||
ImportEntry name src -> Repl.toByteString (state { Repl._imports = Map.insert name (B.byteString src) imports }) Repl.OutputNothing | ||
TypeEntry name src -> Repl.toByteString (state { Repl._types = Map.insert name (B.byteString src) types }) Repl.OutputNothing | ||
DeclEntry name src -> Repl.toByteString (state { Repl._decls = Map.insert name (B.byteString src) decls }) (Repl.OutputDecl name) | ||
ExprEntry src -> Repl.toByteString state (Repl.OutputExpr src) | ||
in | ||
case | ||
do modul <- mapLeft Error.BadSyntax $ Parse.fromByteString Parse.Application (LA.debugPassText "@SOURCE" ( Data.Text.pack $ show source) $ source) | ||
ifaces <- mapLeft Error.BadImports $ checkImports interfaces (Src._imports modul) | ||
artifacts <- Compile.compile Pkg.dummyName ifaces modul | ||
return ( modul, artifacts, objects ) | ||
of | ||
Left err -> | ||
Failure source err | ||
|
||
Right info -> | ||
case entryType of | ||
ImportEntry name _ -> NewImport name | ||
TypeEntry name _ -> NewType name | ||
DeclEntry name _ -> NewWork (toJavaScript info (Just name)) | ||
ExprEntry _ -> NewWork (toJavaScript info Nothing) | ||
|
||
|
||
toJavaScript :: (Src.Module, Compile.Artifacts, Opt.GlobalGraph) -> Maybe N.Name -> B.Builder | ||
toJavaScript (modul, Compile.Artifacts canModule types locals, objects) maybeName = | ||
let | ||
localizer = L.fromModule modul | ||
graph = Opt.addLocalGraph locals objects | ||
home = Can._name canModule | ||
tipe = types ! maybe N.replValueToPrint id maybeName | ||
in | ||
JS.generateForReplEndpoint localizer graph home maybeName tipe | ||
|
||
|
||
mapLeft :: (x -> y) -> Either x a -> Either y a | ||
mapLeft func result = | ||
either (Left . func) Right result | ||
|
||
|
||
checkImports :: Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Either (NE.List Import.Error) (Map.Map ModuleName.Raw I.Interface) | ||
checkImports interfaces imports = | ||
let | ||
importDict = Map.fromValues Src.getImportName imports | ||
missing = Map.difference importDict interfaces | ||
in | ||
case Map.elems missing of | ||
[] -> | ||
Right (Map.intersection interfaces importDict) | ||
|
||
i:is -> | ||
let | ||
unimported = | ||
Map.keysSet (Map.difference interfaces importDict) | ||
|
||
toError (Src.Import (A.At region name) _ _) = | ||
Import.Error region name unimported Import.NotFound | ||
in | ||
Left (fmap toError (NE.List i is)) | ||
|
||
|
||
|
||
-- DECODE BODY | ||
|
||
|
||
decodeBody :: LBS.ByteString -> Maybe ( Repl.State, String ) | ||
decodeBody body = | ||
case Aeson.eitherDecode body of | ||
Right obj -> | ||
Aeson.parseMaybe decodeBodyHelp obj | ||
Left err -> | ||
error $ show err | ||
|
||
|
||
decodeBodyHelp :: Aeson.Object -> Aeson.Parser ( Repl.State, String ) | ||
decodeBodyHelp obj = | ||
let | ||
get key = | ||
do dict <- obj .: key | ||
let f (k,v) = (N.fromChars k, B.stringUtf8 v) | ||
return $ Map.fromList $ map f $ Map.toList dict | ||
in | ||
do imports <- get "imports" | ||
types <- get "types" | ||
decls <- get "decls" | ||
entry <- obj .: "entry" | ||
return ( Repl.State imports types decls, entry ) |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,161 @@ | ||
{-# OPTIONS_GHC -Wall #-} | ||
module ReplArtifacts | ||
( Artifacts(..) | ||
, loadCompile | ||
, loadRepl | ||
, toDepsInfo | ||
) | ||
where | ||
|
||
{- | ||
load artifacts for /extra/Endpoint/Repl. See note (2) in that file. | ||
-} | ||
|
||
|
||
import Control.Concurrent (readMVar) | ||
import Control.Monad (liftM2) | ||
import qualified Data.ByteString as BS | ||
import qualified Data.ByteString.Builder as B | ||
import qualified Data.ByteString.Lazy as LBS | ||
import qualified Data.Map as Map | ||
import qualified Data.Name as N | ||
import qualified Data.OneOrMore as OneOrMore | ||
import qualified System.Directory as Dir | ||
import System.FilePath ((</>)) | ||
|
||
import qualified AST.Canonical as Can | ||
import qualified AST.Optimized as Opt | ||
import qualified BackgroundWriter as BW | ||
import qualified Elm.Details as Details | ||
import qualified Elm.Interface as I | ||
import qualified Elm.ModuleName as ModuleName | ||
import qualified Elm.Package as Pkg | ||
import Json.Encode ((==>)) | ||
import qualified Json.Encode as E | ||
import qualified Json.String as Json | ||
import qualified Reporting | ||
|
||
|
||
|
||
-- ARTIFACTS | ||
|
||
|
||
data Artifacts = | ||
Artifacts | ||
{ _ifaces :: Map.Map ModuleName.Raw I.Interface | ||
, _graph :: Opt.GlobalGraph | ||
} | ||
|
||
|
||
loadCompile :: IO Artifacts | ||
loadCompile = | ||
load ("outlines" </> "compile") | ||
|
||
|
||
loadRepl :: IO Artifacts | ||
loadRepl = | ||
load ("outlines" </> "repl") | ||
|
||
|
||
|
||
-- LOAD | ||
|
||
|
||
load :: FilePath -> IO Artifacts | ||
load dir = | ||
BW.withScope $ \scope -> | ||
do putStrLn $ "Loading " ++ dir </> "elm.json" | ||
style <- Reporting.terminal | ||
root <- fmap (</> dir) Dir.getCurrentDirectory | ||
result <- Details.load style scope root | ||
case result of | ||
Left _ -> | ||
error $ "Ran into some problem loading elm.json\nTry running `lamdera make` in: " ++ dir | ||
|
||
Right details -> | ||
do omvar <- Details.loadObjects root details | ||
imvar <- Details.loadInterfaces root details | ||
mdeps <- readMVar imvar | ||
mobjs <- readMVar omvar | ||
case liftM2 (,) mdeps mobjs of | ||
Nothing -> | ||
error $ "Ran into some weird problem loading elm.json\nTry running `lamdera make` in: " ++ dir | ||
|
||
Just (deps, objs) -> | ||
return $ Artifacts (toInterfaces deps) objs | ||
|
||
|
||
toInterfaces :: Map.Map ModuleName.Canonical I.DependencyInterface -> Map.Map ModuleName.Raw I.Interface | ||
toInterfaces deps = | ||
Map.mapMaybe toUnique $ Map.fromListWith OneOrMore.more $ | ||
Map.elems (Map.mapMaybeWithKey getPublic deps) | ||
|
||
|
||
getPublic :: ModuleName.Canonical -> I.DependencyInterface -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore I.Interface) | ||
getPublic (ModuleName.Canonical _ name) dep = | ||
case dep of | ||
I.Public iface -> Just (name, OneOrMore.one iface) | ||
I.Private _ _ _ -> Nothing | ||
|
||
|
||
toUnique :: OneOrMore.OneOrMore a -> Maybe a | ||
toUnique oneOrMore = | ||
case oneOrMore of | ||
OneOrMore.One value -> Just value | ||
OneOrMore.More _ _ -> Nothing | ||
|
||
|
||
|
||
-- TO DEPS INFO | ||
|
||
|
||
toDepsInfo :: Artifacts -> BS.ByteString | ||
toDepsInfo (Artifacts ifaces _) = | ||
LBS.toStrict $ B.toLazyByteString $ E.encodeUgly $ encode ifaces | ||
|
||
|
||
|
||
-- ENCODE | ||
|
||
|
||
encode :: Map.Map ModuleName.Raw I.Interface -> E.Value | ||
encode ifaces = | ||
E.dict Json.fromName encodeInterface ifaces | ||
|
||
|
||
encodeInterface :: I.Interface -> E.Value | ||
encodeInterface (I.Interface pkg values unions aliases binops) = | ||
E.object | ||
[ "pkg" ==> E.chars (Pkg.toChars pkg) | ||
, "ops" ==> E.list E.name (Map.keys binops) | ||
, "values" ==> E.list E.name (Map.keys values) | ||
, "aliases" ==> E.list E.name (Map.keys (Map.filter isPublicAlias aliases)) | ||
, "types" ==> E.dict Json.fromName (E.list E.name) (Map.mapMaybe toPublicUnion unions) | ||
] | ||
|
||
|
||
isPublicAlias :: I.Alias -> Bool | ||
isPublicAlias alias = | ||
case alias of | ||
I.PublicAlias _ -> True | ||
I.PrivateAlias _ -> False | ||
|
||
|
||
toPublicUnion :: I.Union -> Maybe [N.Name] | ||
toPublicUnion union = | ||
case union of | ||
I.OpenUnion (Can.Union _ variants _ _) -> | ||
Just (map getVariantName variants) | ||
|
||
I.ClosedUnion _ -> | ||
Just [] | ||
|
||
I.PrivateUnion _ -> | ||
Nothing | ||
|
||
|
||
getVariantName :: Can.Ctor -> N.Name | ||
getVariantName (Can.Ctor name _ _ _) = | ||
name |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1 @@ | ||
{"dependencies":{"direct":{"elm/core":"1.0.5","zwilias/elm-rosetree":"1.5.0"},"indirect":{"elm/json":"1.1.3"}},"elm-version":"0.19.1","source-directories":["../../repl-src"],"test-dependencies":{"direct":{},"indirect":{}},"type":"application"} |
Empty file.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
|
@@ -22,6 +22,7 @@ import qualified Data.NonEmptyList as NE | |
import qualified System.Directory as Dir | ||
import System.FilePath as FP | ||
import Snap.Core hiding (path) | ||
import qualified Snap.Core as SnapCore | ||
import Snap.Http.Server | ||
import Snap.Util.FileServe | ||
|
||
|
@@ -54,6 +55,12 @@ import Control.Concurrent.STM (atomically, newTVarIO, readTVar, writeTVar, TVar) | |
|
||
import StandaloneInstances | ||
|
||
import qualified ReplArtifacts | ||
import qualified Endpoint.Repl as Repl | ||
import qualified Endpoint.Package as Package | ||
|
||
import Data.IORef | ||
|
||
-- RUN THE DEV SERVER | ||
|
||
|
||
|
@@ -69,6 +76,7 @@ run () flags = do | |
Dir.setCurrentDirectory root | ||
runWithRoot root flags | ||
|
||
-- currentArtifacts <- liftIO $ readIORef artifactRef | ||
|
||
runWithRoot :: FilePath -> Flags -> IO () | ||
runWithRoot root (Flags maybePort) = | ||
|
@@ -87,6 +95,10 @@ runWithRoot root (Flags maybePort) = | |
|
||
sentryCache <- liftIO $ Sentry.init | ||
|
||
initialArtifacts <- ReplArtifacts.loadRepl | ||
artifactRef <- newIORef initialArtifacts | ||
supermario marked this conversation as resolved.
Show resolved
Hide resolved
|
||
|
||
|
||
let | ||
recompile :: [String] -> IO () | ||
recompile events = do | ||
|
@@ -121,6 +133,9 @@ runWithRoot root (Flags maybePort) = | |
|
||
Lamdera.ReverseProxy.start | ||
|
||
initialArtifacts <- ReplArtifacts.loadRepl | ||
artifactRef <- newIORef initialArtifacts | ||
|
||
Live.withEnd liveState $ | ||
httpServe (config port) $ gcatchlog "general" $ | ||
-- Add /public/* as if it were /* to mirror production, but still render .elm files as an Elm app first | ||
|
@@ -135,6 +150,9 @@ runWithRoot root (Flags maybePort) = | |
<|> route [ ("_r/:endpoint", Live.serveRpc liveState port) ] | ||
<|> Live.openEditorHandler root | ||
<|> Live.serveExperimental root | ||
<|> (SnapCore.path "repl" $ Repl.endpoint artifactRef) | ||
<|> (SnapCore.path "packageList" $ Package.handlePost artifactRef) | ||
<|> (SnapCore.path "reportOnInstalledPackages" $ Package.reportOnInstalledPackages) | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Now that we know what's needed here, I think it might be nice to namespace this as follows:
|
||
<|> serveAssets -- Compiler packaged static files | ||
<|> Live.serveUnmatchedUrlsToIndex root (serveElm sentryCache) -- Everything else without extensions goes to Lamdera LocalDev harness | ||
<|> error404 -- Will get hit for any non-matching extensioned paths i.e. /hello.blah | ||
|
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Add this suggestion to a batch that can be applied as a single commit.
This suggestion is invalid because no changes were made to the code.
Suggestions cannot be applied while the pull request is closed.
Suggestions cannot be applied while viewing a subset of changes.
Only one suggestion per line can be applied in a batch.
Add this suggestion to a batch that can be applied as a single commit.
Applying suggestions on deleted lines is not supported.
You must change the existing code in this line in order to create a valid suggestion.
Outdated suggestions cannot be applied.
This suggestion has been applied or marked resolved.
Suggestions cannot be applied from pending reviews.
Suggestions cannot be applied on multi-line comments.
Suggestions cannot be applied while the pull request is queued to merge.
Suggestion cannot be applied right now. Please check back later.
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
For testing the endpoint that returns a list of installed packages, for example:
curl -X POST -H "Content-Length: 0" http://localhost:8000/reportOnInstalledPackages
[{"name":"elm/parser","version":"1.1.0"},{"name":"elm/core","version":"1.0.5"}]
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
Should I not add comments explaining the purpose of this file?