Repl API

.ghci

@@ -1,4 +1,4 @@
 :set -fbyte-code
 :set -fobject-code
 :set -fwarn-name-shadowing
-:def rr const $ return $ unlines ["Ext.Common.killTrackedThreads",":r","Test.target"]
+:def rr const $ return $ unlines ["Ext.Common.killTrackedThreads",":r","Test.target"]

.github/workflows/build-macos-arm64.yml

@@ -22,6 +22,6 @@ jobs:
       - name: Run distribution script
         run: |
           test -x "$(which ghcup)" && curl https://downloads.haskell.org/~ghcup/aarch64-apple-darwin-ghcup -o ~/.local/bin/ghcup && chmod a+x ~/.local/bin/ghcup
-          brew install llvm@12
+          brew install llvm@13
           cd distribution
           ./build-macos-arm64.sh

.github/workflows/build-macos-x86_64.yml

@@ -22,6 +22,5 @@ jobs:
       - name: Run distribution script
         run: |
           test -x "$(which ghcup)" && curl https://downloads.haskell.org/~ghcup/aarch64-apple-darwin-ghcup -o ~/.local/bin/ghcup && chmod a+x ~/.local/bin/ghcup
-          brew install llvm@12
           cd distribution
           ./build-macos-x86_64.sh

.gitignore

@@ -17,3 +17,6 @@ extra/.cache
 # @TESTS
 elm-home
 
+# Jim
+experimental/
+.vscode/

distribution/build-macos-arm64.sh

@@ -36,7 +36,7 @@ git submodule init && git submodule update
 ffiLibs="$(xcrun --show-sdk-path)/usr/include/ffi"        # Workaround for GHC9.0.2 bug until we can use GHC9.2.3+
 export C_INCLUDE_PATH=$ffiLibs                            # https://gitlab.haskell.org/ghc/ghc/-/issues/20592#note_436353
 
-export PATH="/opt/homebrew/opt/llvm@12/bin:$PATH"         # The arm64 build currently requires llvm until we get to GHC 9.4+
+export PATH="/opt/homebrew/opt/llvm@13/bin:$PATH"         # The arm64 build currently requires llvm until we get to GHC 9.4+
 
 $stack install --local-bin-path $dist
 

elm.cabal

@@ -309,6 +309,9 @@ Executable lamdera
         Test.Wire
         Lamdera.Evergreen.TestMigrationHarness
         Lamdera.Evergreen.TestMigrationGenerator
+        Endpoint.Repl
+        Artifacts
+        Cors
 
 
         -- Debug helpers --
@@ -397,6 +400,7 @@ Executable lamdera
         -- Debug
         unicode-show,
         network-info,
+        network-uri,
 
         -- Future
         conduit-extra,

ext-sentry/Ext/Filewatch.hs

@@ -37,6 +37,7 @@ watch root action =
                 Modified f _ _ -> f
                 Removed f _ _ -> f
                 Unknown f _ _ _ -> f
+                _ -> error $ "unreachable:" ++ show e
 
           -- @TODO it would be better to not listen to these folders in the `watchTree` when available
           -- https://github.com/haskell-fswatch/hfsnotify/issues/101

extra/Artifacts.hs

@@ -0,0 +1,155 @@
+{-# OPTIONS_GHC -Wall #-}
+module Artifacts
+  ( Artifacts(..)
+  , loadCompile
+  , loadRepl
+  , toDepsInfo
+  )
+  where
+
+
+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

extra/Cors.hs

@@ -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"

extra/Endpoint/Package.hs

@@ -0,0 +1,96 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+module Endpoint.Package (handlePost, reportOnInstalledPackages) where
+
+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 Artifacts
+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 Artifacts.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 Artifacts.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