Support custom types with 256-65535 variants

ext-common/Ext/Common.hs

@@ -130,6 +130,16 @@ getProjectRoot tag = do
       -- debug $ "🏠 read project root [" <> tag <> "]: " <> root
       pure root
 
+getProjectRoot_ :: String -> IO (Maybe FilePath)
+getProjectRoot_ tag = do
+  root <- readMVar projectRootMvar
+  case root of
+    ProjectRootUnset -> pure Nothing
+    ProjectRootSet root -> do
+      pure $ Just root
+    ProjectRootContextual root -> do
+      pure $ Just root
+
 
 getProjectRootMaybe :: IO (Maybe FilePath)
 getProjectRootMaybe = do
@@ -139,10 +149,12 @@ getProjectRootMaybe = do
 
 withProjectRoot :: FilePath -> IO a -> IO a
 withProjectRoot root io = do
-  originalRoot <- getProjectRoot "withProjectRoot"
+  originalRootM <- getProjectRoot_ "withProjectRoot"
   setProjectRoot root
   !res <- Dir.withCurrentDirectory root io
-  setProjectRoot originalRoot
+  case originalRootM of
+    Just originalRoot -> setProjectRoot originalRoot
+    Nothing -> pure ()
   pure res
 
 

extra/Lamdera/Compile.hs

@@ -22,7 +22,7 @@ makeOptimized root path = do
 -- Runs `lamdera make --optimize` of given files with no output, followed by the cleanup IO
 makeOptimizedWithCleanup :: IO () -> FilePath -> FilePath -> IO ()
 makeOptimizedWithCleanup cleanup root path = do
-  debug $ "🏗   lamdera make --optimize " <> root <> "/" <> path
+  debug $ "🏗   makeOptimizedWithCleanup: lamdera make --optimize " <> root <> "/" <> path
   let
     tmp = lamderaCache root <> "/tmp.js"
     scaffold = lamderaCache root <> "/Main_.elm"
@@ -55,7 +55,7 @@ makeOptimizedWithCleanup cleanup root path = do
 -- Runs `lamdera make` with no JS output
 make_ :: FilePath -> IO ()
 make_ root = do
-  debug $ "🏗   lamdera make " <> root <> "/"
+  debug $ "🏗   make_: lamdera make " <> root <> "/"
 
   r <- async $
     Ext.Common.withProjectRoot root $
@@ -80,7 +80,7 @@ make_ root = do
 -- Runs `lamdera make` of given files with no JS file output
 makeDev :: FilePath -> [FilePath] -> IO ()
 makeDev root paths = do
-  debug $ "🏗   lamdera make " <> root <> "/" <> show paths
+  debug $ "🏗   makeDev: lamdera make " <> root <> "/" <> show paths
 
   absRoot <- Dir.makeAbsolute root
 
@@ -116,7 +116,7 @@ makeHarnessDevJs root = do
     tmp = lamderaCache root <> "/tmp.js"
     scaffold = lamderaCache root <> "/Main_.elm"
 
-  debug $ "🏗   lamdera make " <> scaffold
+  debug $ "🏗   makeHarnessDevJs: lamdera make " <> scaffold
 
   writeUtf8 scaffold "module Main_ exposing (..)\n\nimport Frontend\nimport Backend\nimport Types\nimport Html\n\nmain = Html.text \"\""
 

extra/Lamdera/Evaluate/Optimized.hs

@@ -141,12 +141,10 @@ evalExpr expr locals globals =
     (Call (VarGlobal (Global (Module.Canonical (Name "elm" "core") "Basics") "eq")) [arg1, arg2]) ->
       case [evalExpr arg1 locals globals, evalExpr arg2 locals globals] of
         [a_, b] -> Bool $ a_ == b
-        _ -> error $ "unexpected args to Basics.eq: " <> show [arg1, arg2]
 
     (Call (VarGlobal (Global (Module.Canonical (Name "elm" "core") "Basics") "neq")) [arg1, arg2]) ->
       case [evalExpr arg1 locals globals, evalExpr arg2 locals globals] of
         [a_, b] -> Bool $ a_ /= b
-        _ -> error $ "unexpected args to Basics.neq: " <> show [arg1, arg2]
 
     (Call (VarGlobal (Global (Module.Canonical (Name "elm" "core") "Basics") "append")) [arg1, arg2]) ->
       case [evalExpr arg1 locals globals, evalExpr arg2 locals globals] of

extra/Lamdera/Injection.hs

@@ -348,7 +348,7 @@ elmPkgJs mode =
           (Just esbuildConfigPath, _, _) ->
             if Ext.Common.isDebug_
               then do
-                Lamdera.debug_ "Building esbuild.config.js"
+                Lamdera.debug_ "🏗️  Building esbuild.config.js"
                 hasNode <- Dir.findExecutable "node"
                 minFile <- case hasNode of
                   Just node -> do
@@ -363,15 +363,17 @@ elmPkgJs mode =
                   Nothing -> do
                     error "no min file after compile, run `node esbuild.config.js` to check errors"
               else do
-                Lamdera.debug_ "Using dumb js packager"
+                Lamdera.debug_ "🏗️🟠  Using dumbJsPackager, ignoring esbuild.config.js in non-dev mode"
                 dumbJsPackager root elmPkgJsSources
           (_, Just esbuildPath, Just includesPath) ->
             if Ext.Common.isDebug_
               then do
                 esbuildIncluder root esbuildPath includesPath
               else do
+                Lamdera.debug_ "🏗️🟠  Using dumbJsPackager, ignoring esbuild in non-dev mode"
                 dumbJsPackager root elmPkgJsSources
-          _ ->
+          _ -> do
+            Lamdera.debug_ "🏗️  Using dumbJsPackager"
             dumbJsPackager root elmPkgJsSources
     _ ->
       ""
@@ -382,10 +384,10 @@ esbuildIncluder root esbuildPath includesPath = do
   minFile <- Lamdera.Relative.loadFile $ root </> "elm-pkg-js-includes.min.js"
   case minFile of
     Just minFileContents -> do
-      Lamdera.debug_ "Using cached elm-pkg-js-includes.min.js"
+      Lamdera.debug_ "🏗️  Using cached elm-pkg-js-includes.min.js"
       pure $ Ext.Common.textToBuilder minFileContents
     Nothing -> do
-      Lamdera.debug_ "Building elm-pkg-js-includes.js"
+      Lamdera.debug_ "🏗️  Building elm-pkg-js-includes.js"
       -- packaged <- Ext.Common.cq_ esbuildPath [ includesPath, "--bundle", "--global-name=elmPkgJsIncludes" ] ""
       (exit, packaged, stdErr) <- Ext.Common.cq_ esbuildPath [ includesPath, "--bundle", "--minify", "--global-name=elmPkgJsIncludes" ] ""
       packaged

extra/Lamdera/Wire3/Core.hs

@@ -42,8 +42,8 @@ import Lamdera.Wire3.Graph
 
 import qualified Ext.ElmFormat
 
-runTests isTest debugName pkg modul decls generatedName generated canonicalValue wiregen =
-  if isTest
+runTests isTest_ debugName pkg modul decls generatedName generated canonicalValue wiregen =
+  if isTest_
     then
       unsafePerformIO $ do
       let
@@ -83,8 +83,8 @@ runTests isTest debugName pkg modul decls generatedName generated canonicalValue
               -- debugPassText ("🧡 expected implementation pretty-printed " <> show_ (Src.getName modul)) (Source2.generateCodecs Map.empty wiregen) (pure ())
               -- debugHaskellPass ("🧡 expected implementation AST.Canonical " <> show_ (Src.getName modul)) (testDefinition) (pure ())
 
-              diff <- icdiff (hindentFormatValue testDefinition) (hindentFormatValue generated)
-              diff2 <- icdiff (ToSource.convert testDefinition) (ToSource.convert generated)
+              -- diff <- icdiff (hindentFormatValue testDefinition) (hindentFormatValue generated)
+              diff2 <- icdiff (ToSource.convert (testDefinition `withName` generatedName)) (ToSource.convert generated)
               -- diff2 <- do
               --   l <- Ext.ElmFormat.format $ ToSource.convert testDefinition
               --   r <- Ext.ElmFormat.format $ ToSource.convert generated
@@ -93,8 +93,8 @@ runTests isTest debugName pkg modul decls generatedName generated canonicalValue
               --           Left err -> show_ err
               --           Right t  -> t
               --   icdiff (withDefault l) (withDefault r)
-              atomicPutStrLn $ "❌❌❌ failed, attempting pretty-print diff1:\n" ++ diff
-              atomicPutStrLn $ "❌❌❌ failed, attempting pretty-print diff2:\n" ++ diff2
+              -- atomicPutStrLn $ "❌❌❌ failed, attempting pretty-print diff1:\n" ++ diff
+              atomicPutStrLn $ "❌❌❌ ASTs do not match, attempting pretty-print diff2:\n" ++ diff2
               -- error "exiting!"
               -- atomicPutStrLn $ "❌❌❌ " ++ Data.Name.toChars (Src.getName modul) ++ "." ++ Data.Name.toChars generatedName ++ " gen does not match test definition."
               pure ()
@@ -147,7 +147,7 @@ addWireGenerations canonical pkg ifaces modul =
 addWireGenerations_ :: Can.Module -> Pkg.Name -> Map.Map Module.Raw I.Interface -> Src.Module -> Either D.Doc Can.Module
 addWireGenerations_ canonical pkg ifaces modul =
   let
-    !isTest = unsafePerformIO Lamdera.isTest
+    !isTest_ = unsafePerformIO Lamdera.isTest
 
     -- !x = unsafePerformIO $ do
     --       case (pkg, Src.getName modul) of
@@ -179,17 +179,17 @@ addWireGenerations_ canonical pkg ifaces modul =
       (Can._unions canonical)
         & Map.toList
         & concatMap (\(name, union) ->
-            [ (encoderUnion isTest ifaces pkg modul decls_ name union)
-            , (decoderUnion isTest ifaces pkg modul decls_ name union)
+            [ (encoderUnion isTest_ ifaces pkg modul decls_ name union)
+            , (decoderUnion isTest_ ifaces pkg modul decls_ name union)
             ]
         )
 
     aliasDefs =
       (Can._aliases canonical)
         & Map.toList
         & concatMap (\(name, alias) ->
-            [ (encoderAlias isTest ifaces pkg modul decls_ name alias)
-            , (decoderAlias isTest ifaces pkg modul decls_ name alias)
+            [ (encoderAlias isTest_ ifaces pkg modul decls_ name alias)
+            , (decoderAlias isTest_ ifaces pkg modul decls_ name alias)
             ]
         )
 
@@ -211,7 +211,7 @@ addWireGenerations_ canonical pkg ifaces modul =
     issues, so we have a record of the things we've tried. -}
     oldDeclsImpl =
       declsToList decls_
-        & List.unionBy (\a b -> defName a == defName b) (unionDefs ++ aliasDefs)
+        & List.unionBy (\a_ b -> defName a_ == defName b) (unionDefs ++ aliasDefs)
         & Lamdera.Wire3.Graph.stronglyConnCompDefs
         & Lamdera.Wire3.Graph.addGraphDefsToDecls SaveTheEnvironment
 
@@ -223,8 +223,8 @@ addWireGenerations_ canonical pkg ifaces modul =
 
         Export exports ->
           newDefs
-            & foldl (\exports def ->
-                addExport def exports
+            & foldl (\exports_ def ->
+                addExport def exports_
               )
               exports
             & Export
@@ -245,9 +245,9 @@ addExport def exports =
 
 
 encoderUnion :: Bool -> Map.Map Module.Raw I.Interface -> Pkg.Name -> Src.Module -> Decls -> Data.Name.Name -> Union -> Def
-encoderUnion isTest ifaces pkg modul decls unionName union =
+encoderUnion isTest_ ifaces pkg modul decls unionName union =
   let
-    !x = runTests isTest "encoderUnion" pkg modul decls generatedName finalGen union (unionAsModule cname unionName union)
+    !x = runTests isTest_ "encoderUnion" pkg modul decls generatedName finalGen union (unionAsModule cname unionName union)
 
     generatedName = Data.Name.fromChars $ "w3_encode_" ++ Data.Name.toChars unionName
     cname = Module.Canonical pkg (Src.getName modul)
@@ -258,6 +258,15 @@ encoderUnion isTest ifaces pkg modul decls unionName union =
         (pvar $ Data.Name.fromChars $ "w3_x_c_" ++ Data.Name.toChars tvar, TLambda (TVar tvar) tLamdera_Wire_Encoder_Holey)
       )
 
+    numCtors = length $ _u_alts union
+
+    variantIntEncoder n
+      | numCtors <= 255        = encodeUnsignedInt8 (int n)
+      | numCtors <= 65535      = encodeUnsignedInt16 (int n)
+      -- Truly ridiculous but... maybe one day? 🪐
+      -- | numCtors <= 4294967295 = encodeUnsignedInt32 (int n)
+      | otherwise              = error $ "Unhandled custom type variant size (" ++ show n ++ "), please report this issue for the custom type " ++ Data.Name.toChars unionName
+
     generatedBody =
         -- debugEncoder_ (Data.Name.toElmString unionName)
         (caseof (lvar "w3v") $
@@ -266,18 +275,24 @@ encoderUnion isTest ifaces pkg modul decls unionName union =
               & imap (\i (Ctor tagName tagIndex numParams paramTypes) ->
                   let
                     params =
-                      paramTypes & imap (\i paramType ->
+                      paramTypes & imap (\pi_ paramType ->
                         PatternCtorArg
-                          { _index = Index.ZeroBased i
+                          { _index = Index.ZeroBased pi_
                           , _type = paramType
-                          , _arg = pvar (Data.Name.fromChars $ "v" ++ show i)
+                          , _arg = pvar (Data.Name.fromChars $ "v" ++ show pi_)
                           }
                       )
 
                     paramEncoders =
-                      paramTypes & imap (\i paramType ->
-                          encodeTypeValue 0 ifaces cname paramType (lvar (Data.Name.fromChars $ "v" ++ show i))
+                      paramTypes & imap (\pi_ paramType ->
+                          encodeTypeValue 0 ifaces cname paramType (lvar (Data.Name.fromChars $ "v" ++ show pi_))
                       )
+
+                    branchHandler =
+                      if numParams == 0 then
+                        variantIntEncoder i
+                      else
+                        encodeSequenceWithoutLength $ list $ [ variantIntEncoder i ] ++ paramEncoders
                   in
                   CaseBranch
                     (a (PCtor
@@ -288,7 +303,7 @@ encoderUnion isTest ifaces pkg modul decls unionName union =
                       , _p_index = tagIndex
                       , _p_args = params
                       }))
-                    (encodeSequenceWithoutLength $ list $ [ encodeUnsignedInt8 (int i) ] ++ paramEncoders)
+                    branchHandler
               )
             )
 
@@ -318,9 +333,9 @@ encoderUnion isTest ifaces pkg modul decls unionName union =
 
 
 decoderUnion :: Bool -> Map.Map Module.Raw I.Interface -> Pkg.Name -> Src.Module -> Decls -> Data.Name.Name -> Union -> Def
-decoderUnion isTest ifaces pkg modul decls unionName union =
+decoderUnion isTest_ ifaces pkg modul decls unionName union =
   let
-    !x = runTests isTest "decoderUnion" pkg modul decls generatedName generated union (unionAsModule cname unionName union)
+    !x = runTests isTest_ "decoderUnion" pkg modul decls generatedName generated union (unionAsModule cname unionName union)
 
     generatedName = Data.Name.fromChars $ "w3_decode_" ++ Data.Name.toChars unionName
     cname = Module.Canonical pkg (Src.getName modul)
@@ -336,14 +351,23 @@ decoderUnion isTest ifaces pkg modul decls unionName union =
       in
       (a (VarCtor (_u_opts union) cname tagName index (Forall tvarsTypesig constructorType)))
 
+    numCtors = length $ _u_alts union
+
+    variantIntDecoder
+      | numCtors <= 255        = decodeUnsignedInt8
+      | numCtors <= 65535      = decodeUnsignedInt16
+      -- Truly ridiculous but... maybe one day? 🪐
+      -- | numCtors <= 4294967295 = decodeUnsignedInt32
+      | otherwise = error $ "Unhandled custom type variant size (" ++ show numCtors ++ "), please report this issue for the custom type " ++ Data.Name.toChars unionName
+
     generated =
       Def
       -- TypedDef
         (a (generatedName))
         -- Map.empty
         ptvars $
         -- debugDecoder (Data.Name.toElmString unionName)
-        (decodeUnsignedInt8 |> andThenDecode1
+        (variantIntDecoder |> andThenDecode1
               (lambda1 (pvar "w3v") $
                 caseof (lvar "w3v") $
                   _u_alts union
@@ -367,9 +391,9 @@ decoderUnion isTest ifaces pkg modul decls unionName union =
 
 
 encoderAlias :: Bool -> Map.Map Module.Raw I.Interface -> Pkg.Name -> Src.Module -> Decls -> Data.Name.Name -> Alias -> Def
-encoderAlias isTest ifaces pkg modul decls aliasName alias@(Alias tvars tipe) =
+encoderAlias isTest_ ifaces pkg modul decls aliasName alias@(Alias tvars tipe) =
   let
-    !x = runTests isTest "encoderAlias" pkg modul decls generatedName finalGen alias (aliasAsModule cname aliasName alias)
+    !x = runTests isTest_ "encoderAlias" pkg modul decls generatedName finalGen alias (aliasAsModule cname aliasName alias)
 
     generatedName = Data.Name.fromChars $ "w3_encode_" ++ Data.Name.toChars aliasName
     cname = Module.Canonical pkg (Src.getName modul)
@@ -424,9 +448,9 @@ encoderAlias isTest ifaces pkg modul decls aliasName alias@(Alias tvars tipe) =
 
 
 decoderAlias :: Bool -> Map.Map Module.Raw I.Interface -> Pkg.Name -> Src.Module -> Decls -> Data.Name.Name -> Alias -> Def
-decoderAlias isTest ifaces pkg modul decls aliasName alias@(Alias tvars tipe) =
+decoderAlias isTest_ ifaces pkg modul decls aliasName alias@(Alias tvars tipe) =
   let
-    !x = runTests isTest "decoderAlias" pkg modul decls generatedName generated alias (aliasAsModule cname aliasName alias)
+    !x = runTests isTest_ "decoderAlias" pkg modul decls generatedName generated alias (aliasAsModule cname aliasName alias)
 
     generatedName = Data.Name.fromChars $ "w3_decode_" ++ Data.Name.toChars aliasName
     cname = Module.Canonical pkg (Src.getName modul)