Add support for LocalDev.elm modules

builder/src/Elm/Outline.hs

@@ -202,7 +202,7 @@ read root shouldCheckLamdera =
                 then Left Exit.OutlineNoPkgCore
                 else Right outline
 
-            App (AppOutline _ srcDirs direct indirect _ _)
+            App (AppOutline version srcDirs@(NE.List srcHead srcTail) direct indirect testDirect testIndirect)
               | Map.notMember Pkg.core direct ->
                   return $ Left Exit.OutlineNoAppCore
 
@@ -219,8 +219,9 @@ read root shouldCheckLamdera =
                           do  maybeDups <- detectDuplicates root (NE.toList srcDirs)
                               case maybeDups of
                                 Nothing ->
+                                  let newSrcDirs = NE.List srcHead (AbsoluteSrcDir (Lamdera.lamderaCache root) : srcTail) in
                                   Lamdera.alternativeImplementationPassthrough (Lamdera.Checks.runChecks root shouldCheckLamdera direct) $
-                                  return $ Right outline
+                                  return $ Right (App (AppOutline version newSrcDirs direct indirect testDirect testIndirect))
 
                                 Just (canonicalDir, (dir1,dir2)) ->
                                   return $ Left (Exit.OutlineHasDuplicateSrcDirs canonicalDir dir1 dir2)

extra/Lamdera/CLI/Live.hs

@@ -11,31 +11,27 @@ import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BSL
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
-import qualified Data.Text.IO as T
-import qualified Data.Text.Encoding as T
-import qualified Data.Text.Lazy.Encoding as TL
-import qualified Data.Text.Lazy.Builder as TLB
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text.Lazy.Encoding as TLE
 import qualified Data.Map as Map
 import qualified Data.HashMap.Strict as HashMap
 import qualified Data.List as List
+import Data.Maybe (fromMaybe)
 import GHC.Word (Word64)
 
 import qualified System.Directory as Dir
-import System.FilePath as FP
+import System.FilePath ((</>), takeExtension)
 import Control.Applicative ((<|>))
 import Control.Arrow ((***))
-import Control.Concurrent.STM (atomically, newTVarIO, readTVar, writeTVar, TVar)
-import Control.Exception (finally, throw)
-import Language.Haskell.TH (runIO)
+import Control.Concurrent.STM (atomically, newTVarIO, readTVar, readTVarIO, writeTVar, TVar)
+import Control.Exception (finally)
+import qualified Language.Haskell.TH as TH
 import Data.FileEmbed (bsToExp)
 import qualified Data.Aeson.Encoding as A
 
 import Snap.Core hiding (path, headers)
-import qualified Data.CaseInsensitive as CI (original, mk)
-import qualified Data.Bifunctor (first)
+import qualified Data.CaseInsensitive as CI
 
-import qualified Develop.Generate.Help as Generate
-import qualified Develop.StaticFiles as StaticFiles
 import qualified Json.Decode as D
 import qualified Json.Encode as E
 import qualified Json.String
@@ -45,19 +41,15 @@ import Lamdera
 import qualified Data.UUID as UUID
 import qualified Data.UUID.V4 as UUID
 import BroadcastChan
-import Control.Timeout
-import Data.Time.Clock (getCurrentTime, diffUTCTime)
-import qualified Network.WebSockets      as WS
+import Control.Timeout (timeout)
 import qualified Network.WebSockets.Snap as WS
 import SocketServer
-import Data.Word (Word8)
-import System.Process
 
-import System.Entropy
+import System.Entropy (getEntropy)
 import Snap.Util.FileServe (
-    getSafePath, serveDirectoryWith, defaultDirectoryConfig, defaultMimeTypes, mimeTypes, MimeMap, DirectoryConfig
+    getSafePath, serveDirectoryWith, defaultDirectoryConfig, defaultMimeTypes, mimeTypes, DirectoryConfig
   )
-import Control.Monad (guard, void)
+import Control.Monad (guard)
 
 import qualified Lamdera.CLI.Check
 import qualified Lamdera.Relative
@@ -91,7 +83,7 @@ withEnd (mClients, mLeader, mChan, beState) io = do
   let
     end = do
       debug "[backendSt] 🧠"
-      text <- atomically $ readTVar beState
+      text <- readTVarIO beState
       bePath <- lamderaBackendDevSnapshotPath
       writeUtf8 bePath text
 
@@ -133,10 +125,7 @@ serveUnmatchedUrlsToIndex root serveElm =
 
 prepareLocalDev :: FilePath -> IO FilePath
 prepareLocalDev root = do
-  overrideM <- Lamdera.Relative.readFile "extra/LocalDev/LocalDev.elm"
-  let
-    cache = lamderaCache root
-    harnessPath = cache </> "LocalDev.elm"
+  overrideM <- Lamdera.Relative.readDir TE.decodeUtf8 "extra/LocalDev/runtime-src"
 
   -- This needs to be moved to an on-demand action, as it has to query production and
   -- thus isn't appropriate to run on every single recompile
@@ -145,22 +134,23 @@ prepareLocalDev root = do
 
   rpcExists <- doesFileExist $ root </> "src" </> "RPC.elm"
 
-  case overrideM of
-    Just override -> do
-      writeIfDifferent harnessPath
-        (override
-          & replaceVersionMarker
-          & replaceRpcMarker rpcExists
-        )
+  let
+    cache = lamderaCache root
+    harnessPath = "LocalDev.elm"
+
+    patchedContent path content =
+      if path == harnessPath
+        then content & replaceVersionMarker & replaceRpcMarker rpcExists
+        else content
+
+    processFile (path, content) =
+      writeIfDifferent (cache </> path) $ patchedContent path content
+
+    files = fromMaybe lamderaLocalDevDir overrideM
 
-    Nothing ->
-      writeIfDifferent harnessPath
-        (lamderaLocalDev
-          & replaceVersionMarker
-          & replaceRpcMarker rpcExists
-        )
+  mapM_ processFile files
 
-  pure harnessPath
+  pure $ cache </> harnessPath
 
 
 replaceVersionMarker :: Text -> Text
@@ -205,9 +195,13 @@ replaceRpcMarker shouldReplace localdev =
           \            {-}"
 
 
-lamderaLocalDev :: Text
-lamderaLocalDev =
-  T.decodeUtf8 $(bsToExp =<< runIO (Lamdera.Relative.readByteString "extra/LocalDev/LocalDev.elm"))
+lamderaLocalDevDir :: [(FilePath, Text)]
+lamderaLocalDevDir =
+  $(do
+      bsPairs <- TH.runIO (Lamdera.Relative.readDir id "extra/LocalDev/runtime-src")
+      let toTuple (fp, bs) = [| (fp, TE.decodeUtf8 $(bsToExp bs)) |]
+      TH.ListE <$> mapM toTuple (fromMaybe [] bsPairs)
+   )
 
 
 refreshClients (mClients, mLeader, mChan, beState) =
@@ -229,10 +223,10 @@ serveWebsocket root (mClients, mLeader, mChan, beState) =
             let cookie = Cookie "sid" newSid Nothing Nothing Nothing False False
             modifyResponse $ addResponseCookie cookie
 
-            pure $ T.decodeUtf8 $ newSid
+            pure $ TE.decodeUtf8 $ newSid
 
           Just sid_ ->
-            pure $ T.decodeUtf8 $ cookieValue sid_
+            pure $ TE.decodeUtf8 $ cookieValue sid_
 
       case mKey of
         Just key -> do
@@ -252,14 +246,14 @@ serveWebsocket root (mClients, mLeader, mChan, beState) =
                 onlyWhen leaderChanged $ do
                   sendToLeader mClients mLeader (\leader -> do
                       -- Tell the new leader about the backend state they need
-                      atomically $ readTVar beState
+                      readTVarIO beState
                     )
                   -- Tell everyone about the new leader (also causes actual leader to go active as leader)
                   broadcastLeader mClients mLeader
 
                 SocketServer.broadcastImpl mClients $ "{\"t\":\"c\",\"s\":\"" <> sessionId <> "\",\"c\":\"" <> clientId <> "\"}"
 
-                leader <- atomically $ readTVar mLeader
+                leader <- readTVarIO mLeader
                 case leader of
                   Just leaderId ->
                     pure $ Just $ "{\"t\":\"s\",\"c\":\"" <> clientId <> "\",\"l\":\"" <> leaderId <> "\"}"
@@ -308,7 +302,7 @@ serveWebsocket root (mClients, mLeader, mChan, beState) =
                       SocketServer.broadcastImpl mClients text
 
           WS.runWebSocketsSnap $
-            SocketServer.socketHandler mClients mLeader beState onJoined onReceive (T.decodeUtf8 key) sessionId
+            SocketServer.socketHandler mClients mLeader beState onJoined onReceive (TE.decodeUtf8 key) sessionId
 
         Nothing ->
           error404 "missing sec-websocket-key header"
@@ -399,9 +393,9 @@ serveExperimentalWrite root path = do
     Just "image/jpeg"               -> Lamdera.writeBinary fullpath rbody
 
     _ ->
-      writeIfDifferent fullpath (TL.toStrict $ TL.decodeUtf8 rbody)
+      writeIfDifferent fullpath (TL.toStrict $ TLE.decodeUtf8 rbody)
 
-  jsonResponse $ B.byteString $ "{ written: '" <> T.encodeUtf8 (T.pack fullpath) <> "'}"
+  jsonResponse $ B.byteString $ "{ written: '" <> TE.encodeUtf8 (T.pack fullpath) <> "'}"
 
 
 serveExperimentalList :: FilePath -> Text -> Snap ()
@@ -543,10 +537,10 @@ serveRpc (mClients, mLeader, mChan, beState) port = do
         let cookie = Cookie "sid" newSid Nothing Nothing Nothing False False
         modifyResponse $ addResponseCookie cookie
 
-        pure $ T.decodeUtf8 $ newSid
+        pure $ TE.decodeUtf8 $ newSid
 
       Just sid_ ->
-        pure $ T.decodeUtf8 $ cookieValue sid_
+        pure $ TE.decodeUtf8 $ cookieValue sid_
 
   onlyWhen (mEndpoint == Nothing) $ error500 "no endpoint present"
 
@@ -570,10 +564,10 @@ serveRpc (mClients, mLeader, mChan, beState) port = do
     -- Unfortunately the JSON string encoding logic is hidden inside Data.Aeson.Encoding.Internal
     -- so off we go with all the silly format hops
     escapeJsonString :: Text -> Text
-    escapeJsonString t = A.text t & A.encodingToLazyByteString & BSL.toStrict & T.decodeUtf8
+    escapeJsonString t = A.text t & A.encodingToLazyByteString & BSL.toStrict & TE.decodeUtf8
 
     escapedBody =
-      rbody & TL.decodeUtf8 & TL.toStrict & escapeText
+      rbody & TLE.decodeUtf8 & TL.toStrict & escapeText
 
     escapeText :: Text -> E.Value
     escapeText t =
@@ -588,14 +582,14 @@ serveRpc (mClients, mLeader, mChan, beState) port = do
       E.object
           [ ("t", E.string "q")
           , ("s", E.text sid)
-          , ("e", E.text $ T.decodeUtf8 endpoint)
+          , ("e", E.text $ TE.decodeUtf8 endpoint)
           , ("r", E.text reqId)
           , ("h", E.String $ Ext.Common.textToBuilder $ encodeToText requestHeadersJson)
           , value
           ]
         & encodeToText
 
-    encodeToText encoder = encoder & E.encode & B.toLazyByteString & BSL.toStrict & T.decodeUtf8
+    encodeToText encoder = encoder & E.encode & B.toLazyByteString & BSL.toStrict & TE.decodeUtf8
 
     requestPayload =
       case contentType of
@@ -619,14 +613,14 @@ serveRpc (mClients, mLeader, mChan, beState) port = do
                     values =
                       case vals of
                         [] -> "null"
-                        val:[] -> T.concat ["\"", (T.decodeUtf8 val & escapeJsonString), "\""]
+                        val:[] -> T.concat ["\"", (TE.decodeUtf8 val & escapeJsonString), "\""]
                         _ ->
                           vals
-                            & fmap (\v -> T.concat ["\"", (T.decodeUtf8 v & escapeJsonString), "\""])
+                            & fmap (\v -> T.concat ["\"", (TE.decodeUtf8 v & escapeJsonString), "\""])
                             & T.intercalate ","
                             & (\v -> T.concat ["[", v, "]"])
                   in
-                  T.concat ["\"", T.decodeUtf8 key, "\":", values]
+                  T.concat ["\"", TE.decodeUtf8 key, "\":", values]
                 )
                 & (\v -> T.concat ["{", (v & T.intercalate ","), "}"])
           in
@@ -648,7 +642,7 @@ serveRpc (mClients, mLeader, mChan, beState) port = do
           | otherwise -> loopRead
         Nothing -> loopRead
 
-  leader <- liftIO $ atomically $ readTVar mLeader
+  leader <- liftIO $ readTVarIO mLeader
   case leader of
     Just leaderId -> do
       liftIO $ sendToLeader mClients mLeader (\leader_ -> pure requestPayload)
@@ -672,12 +666,12 @@ serveRpc (mClients, mLeader, mChan, beState) port = do
                     ])
 
             decodeResult =
-              D.fromByteString decoder (T.encodeUtf8 chanText)
+              D.fromByteString decoder (TE.encodeUtf8 chanText)
 
           case decodeResult of
             Right (statusCode, statusText, headers, (bodyType, bodyEncoded)) -> do
 
-              let response = TL.toStrict $ TL.decodeUtf8 $ B.toLazyByteString bodyEncoded
+              let response = TL.toStrict $ TLE.decodeUtf8 $ B.toLazyByteString bodyEncoded
               debugT $ "RPC:↙️  response:" <> response
               debug $ show (statusCode, statusText)
               onlyWhen (bodyType == "i") (modifyResponse $ setContentType "application/octet-stream")
@@ -694,12 +688,12 @@ serveRpc (mClients, mLeader, mChan, beState) port = do
 
             Left jsonProblem -> do
               debugT $ "😢 rpc response decoding failed: " <> show_ jsonProblem <> "\n" <> chanText
-              writeBuilder $ B.byteString $ "rpc response decoding failed for " <> T.encodeUtf8 chanText
+              writeBuilder $ B.byteString $ "rpc response decoding failed for " <> TE.encodeUtf8 chanText
 
 
         Nothing -> do
           debugT $ "⏰ RPC timed out for:" <> requestPayload
-          writeBuilder $ B.byteString $ T.encodeUtf8 $ "error:timeout:" <> show_ seconds <> "s"
+          writeBuilder $ B.byteString $ TE.encodeUtf8 $ "error:timeout:" <> show_ seconds <> "s"
 
 
     Nothing -> do
@@ -721,7 +715,7 @@ _10MB =
 logger :: BS.ByteString -> IO ()
 logger =
   (\bs ->
-    atomicPutStrLn $ T.unpack $ T.decodeUtf8 bs
+    atomicPutStrLn $ T.unpack $ TE.decodeUtf8 bs
   )
 
 jsonResponse :: B.Builder -> Snap ()