diff --git a/compiler/src/Compile.hs b/compiler/src/Compile.hs index c48fa269c..315a1f2c2 100644 --- a/compiler/src/Compile.hs +++ b/compiler/src/Compile.hs @@ -28,11 +28,6 @@ import qualified Type.Solve as Type -- import System.IO.Unsafe (unsafePerformIO) - --- @DEPRECATED for alpha12 release migration only -import qualified Lamdera.Wire2.Core -import qualified Lamdera.Wire2.Interfaces - import qualified Lamdera.Wire3.Core import qualified Lamdera.Wire3.Interfaces import qualified Lamdera.Wire3.Helpers as Lamdera.Wire @@ -67,16 +62,14 @@ compile pkg ifaces modul = do let modul_ = modul & Lamdera.Wire3.Interfaces.modifyModul pkg ifaces - -- & Lamdera.Wire2.Interfaces.modifyModul pkg ifaces -- moduleName = T.pack $ Data.Utf8.toChars $ Src.getName modul -- () <- debugPassText "starting canonical" "" (pure ()) canonical0 <- canonicalize pkg ifaces modul_ -- () <- debugPassText "starting canonical2" moduleName (pure ()) - -- Add Canonical Wire gens, i.e. the `w2_[en|de]code_TYPENAME` functions + -- Add Canonical Wire gens, i.e. the `w3_[en|de]code_TYPENAME` functions canonical2 <- Lamdera.Wire3.Core.addWireGenerations canonical0 pkg ifaces modul_ - -- canonical2 <- Lamdera.Wire2.Core.addWireGenerations canonical1 pkg ifaces modul_ -- () <- unsafePerformIO $ do -- case (pkg, Src.getName modul) of diff --git a/elm.cabal b/elm.cabal index 27f6e829e..4f5b56605 100644 --- a/elm.cabal +++ b/elm.cabal @@ -264,12 +264,6 @@ Executable lamdera Lamdera.Types Lamdera.Update Lamdera.Version - Lamdera.Wire2.Core - Lamdera.Wire2.Decoder - Lamdera.Wire2.Encoder - Lamdera.Wire2.Graph - Lamdera.Wire2.Helpers - Lamdera.Wire2.Interfaces Lamdera.Wire3.Core Lamdera.Wire3.Decoder Lamdera.Wire3.Encoder @@ -298,8 +292,7 @@ Executable lamdera -- Lamdera Legacy -- Lamdera.Legacy - -- Wire.Source - -- Wire.Source2 + -- Wire.Source3 -- Fusion -- Fusion.Types diff --git a/extra/Lamdera/Evergreen/MigrationHarness.hs b/extra/Lamdera/Evergreen/MigrationHarness.hs index 4a4aca966..547605add 100644 --- a/extra/Lamdera/Evergreen/MigrationHarness.hs +++ b/extra/Lamdera/Evergreen/MigrationHarness.hs @@ -128,7 +128,6 @@ decodeAndUpgradeFor migrationSequence nextVersion valueType = do [text| $nextVersion_ -> decodeType $valueTypeInt version bytes T$nextVersion_.w3_decode_$valueType - |> fallback (\_ -> decodeType $valueTypeInt version bytes T$nextVersion_.w2_decode_$valueType) |> upgradeIsCurrent |> otherwiseError |] @@ -262,7 +261,6 @@ migrationForType migrationSequence migrationsForVersion startVersion finalVersio then [text| decodeType $valueTypeInt $finalVersion_ bytes T$finalVersion_.w3_decode_$tipe - |> fallback (\_ -> decodeType $valueTypeInt $finalVersion_ bytes T$finalVersion_.w2_decode_$tipe) |> upgradeSucceeds |> otherwiseError |] @@ -278,7 +276,6 @@ migrationForType migrationSequence migrationsForVersion startVersion finalVersio then [text| decodeType $valueTypeInt $startVersion_ bytes T$startVersion_.w3_decode_$tipe - |> fallback (\_ -> decodeType $valueTypeInt $startVersion_ bytes T$startVersion_.w2_decode_$tipe) $intermediateMigrationsFormatted |> upgradeSucceeds |> otherwiseError diff --git a/extra/Lamdera/Wire2/Core.hs b/extra/Lamdera/Wire2/Core.hs deleted file mode 100644 index a40d775e1..000000000 --- a/extra/Lamdera/Wire2/Core.hs +++ /dev/null @@ -1,363 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE BangPatterns #-} -module Lamdera.Wire2.Core where - -{- - -All the code that does the Wire encoder/decoder code gen and injection - --- @EXTENSIBLERECORDS search for this tag for issues related to skipping -support for extensible records ATM. - --} - -import System.IO.Unsafe (unsafePerformIO) -import qualified Data.Map as Map -import qualified Data.List as List - -import Elm.Package -import qualified AST.Source as Src -import qualified Elm.Interface as I -import qualified Elm.ModuleName as Module -import qualified Elm.Package as Pkg -import qualified AST.Canonical as Can -import AST.Canonical -import qualified Data.Name -import qualified Data.Utf8 as Utf8 -import qualified Reporting.Annotation as A -import qualified Reporting.Error as E -import qualified Reporting.Doc as D -import qualified Data.Text as T -import qualified Data.Index as Index - --- import qualified Wire.Source2 as Source2 - -import StandaloneInstances -import qualified CanSer.CanSer as ToSource - -import Lamdera -import qualified Lamdera.Project -import Lamdera.Wire2.Helpers -import Lamdera.Wire2.Encoder -import Lamdera.Wire2.Decoder -import Lamdera.Wire2.Graph - - -runTests isTest debugName pkg modul decls generatedName generated canonicalValue wire2gen = - if isTest - then - unsafePerformIO $ do - let - testName = Data.Name.fromChars $ "expected_" ++ Data.Name.toChars generatedName - - withName def n_ = - case def of - Def (A.At r n) p e -> Def (A.At r n_) p e - TypedDef (A.At r n) freeVars pts e t -> TypedDef (A.At r n_) freeVars pts e t - - fullTypeRef = - (T.pack $ Pkg.toChars pkg) <> ":" <> (T.pack $ Data.Name.toChars $ Src.getName modul) <> "." <> (T.pack $ Data.Name.toChars generatedName) - - case decls & findDef testName of - Just testDefinition -> do - - -- debugHaskellPass ("πŸ’š testDefinition " <> show_ (Src.getName modul)) (testDefinition) (pure ()) - -- debugHaskellPass ("🧑 generated " <> show_ (Src.getName modul)) (generated) (pure ()) - -- diff <- icdiff (hindentFormatValue testDefinition) (hindentFormatValue generated) - -- atomicPutStrLn $ "❌❌❌ failed, attempting pretty-print diff:\n" ++ diff - - if generated == testDefinition `withName` generatedName - then do - -- atomicPutStrLn $ "βœ… gen " <> debugName <> " matches " <> Data.Name.toChars (Src.getName modul) <> "." <> Data.Name.toChars testName - -- debugPassText ("🧑 expected implementation pretty-printed " <> show_ (Src.getName modul)) (Source2.generateCodecs Map.empty wire2gen) (pure ()) - pure () - - else do - -- debugHaskellPass ("🏁 Actual value input for " <> (T.pack $ Data.Name.toChars generatedName)) (canonicalValue) (pure ()) - -- debugPassText ("πŸ’š actual implementation pretty-printed " <> show_ (Src.getName modul)) (ToSource.convert generated) (pure ()) - -- debugPassText ("🧑 expected implementation pretty-printed " <> show_ (Src.getName modul)) (Source2.generateCodecs Map.empty wire2gen) (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) - -- atomicPutStrLn $ "❌❌❌ failed, attempting pretty-print diff1:\n" ++ diff - atomicPutStrLn $ "❌❌❌ failed, 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 () - - Nothing -> do - -- atomicPutStrLn $ "⚠️ Warning: test not found " ++ show pkg ++ ":" ++ Data.Name.toChars (Src.getName modul) ++ "." ++ Data.Name.toChars testName -- ++ "\n" ++ show (declsToList decls & fmap defName) - -- debugPassText ("🧑 expected implementation pretty-printed " <> fullTypeRef) (Source2.generateCodecs Map.empty wire2gen) (pure ()) - -- error "exiting!" - pure () - - else () - -unionAsModule cname name union = - Can.Module - { Can._name = cname - , Can._exports = Can.ExportEverything A.zero - , Can._docs = Src.NoDocs A.zero - , Can._decls = Can.SaveTheEnvironment - , Can._unions = Map.singleton name union - , Can._aliases = Map.empty - , Can._binops = Map.empty - , Can._effects = NoEffects - } - -aliasAsModule cname name alias = - Can.Module - { Can._name = cname - , Can._exports = Can.ExportEverything A.zero - , Can._docs = Src.NoDocs A.zero - , Can._decls = Can.SaveTheEnvironment - , Can._unions = Map.empty - , Can._aliases = Map.singleton name alias - , Can._binops = Map.empty - , Can._effects = NoEffects - } - -addWireGenerations :: Can.Module -> Pkg.Name -> Map.Map Module.Raw I.Interface -> Src.Module -> Either E.Error Can.Module -addWireGenerations canonical pkg ifaces modul = - if Lamdera.Wire2.Helpers.shouldHaveCodecsGenerated pkg then - case addWireGenerations_ canonical pkg ifaces modul of - Right canonical_ -> do - Right canonical_ - - Left err -> - Left $ E.BadLamdera "WIRE ERROR" err - else - Right canonical - - -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 - - -- !x = unsafePerformIO $ do - -- case (pkg, Src.getName modul) of - -- -- ((Name "Skinney" "elm-deque"), "OldDeque") -> do - -- ((Name "author" "project"), "Test.Wire_Recursive") -> do - -- formatHaskellValue "declsBefore" $ declsToSummary $ Can._decls canonical - -- formatHaskellValue "declsAfter" $ declsToSummary $ extendedDecls - -- - -- _ -> - -- pure () - - -- !x = unsafePerformIO $ do - -- case (pkg, Src.getName modul) of - -- ((Name "elm" "regex"), "Regex") -> do - -- -- ((Name "author" "project"), "Subdir.Subsubdir.SubsubdirType") -> do - -- - -- newDefs - -- & fmap ToSource.convert - -- & mapM (atomicPutStrLn . T.unpack) - -- -- formatHaskellValue "declsAfter" $ declsToSummary $ extendedDecls - -- pure () - -- - -- _ -> - -- pure () - - decls_ = Can._decls canonical - - unionDefs = - (Can._unions canonical) - & Map.toList - & concatMap (\(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) - ] - ) - - newDefs = - (unionDefs ++ aliasDefs) - - {- Existing decls, with the injected Wire.Interface placeholders removed -} - existingDecls = - foldl (\def decls -> removeDef decls def ) decls_ newDefs - - extendedDecls = - newDefs - & Lamdera.Wire2.Graph.stronglyConnCompDefs - & Lamdera.Wire2.Graph.addGraphDefsToDecls existingDecls - - {- This implementation sorted all decls, however sorting only by lvar is - not a valid dependency sort for all functions, only for wire functions! - Left here for reference temporarily in case the new approach also causes - 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) - & Lamdera.Wire2.Graph.stronglyConnCompDefs - & Lamdera.Wire2.Graph.addGraphDefsToDecls SaveTheEnvironment - - {- For any modules that don't ExportEverything, we add our newDefs to exports -} - extendedExports = - case Can._exports canonical of - ExportEverything region -> - ExportEverything region - - Export exports -> - newDefs - & foldl (\exports def -> - addExport def exports - ) - exports - & Export - in - Right $ canonical - { _decls = extendedDecls - , _exports = extendedExports - } - - -addExport :: Def -> Map.Map Data.Name.Name (A.Located Export) -> Map.Map Data.Name.Name (A.Located Export) -addExport def exports = - case def of - Def (A.At region name_) pvars expr -> - Map.insert name_ (a ExportValue) exports - TypedDef (A.At region name_) freeVars pvars expr tipe -> - Map.insert name_ (a ExportValue) 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 = - let - !x = runTests isTest "encoderUnion" pkg modul decls generatedName generated union (unionAsModule cname unionName union) - - generatedName = Data.Name.fromChars $ "w2_encode_" ++ Data.Name.toChars unionName - cname = Module.Canonical pkg (Src.getName modul) - tvars = _u_vars union - ptvars = tvars & fmap (\tvar -> pvar $ Data.Name.fromChars $ "w2_x_c_" ++ Data.Name.toChars tvar ) - - generated = - Def - (a (generatedName)) - (ptvars ++ [ pvar "w2v" ]) $ - -- debugEncoder_ (Data.Name.toElmString unionName) - (caseof (lvar "w2v") $ - _u_alts union - & List.sortOn (\(Ctor name index_ numParams paramTypes) -> name) - & imap (\i (Ctor tagName tagIndex numParams paramTypes) -> - let - params = - paramTypes & imap (\i paramType -> - PatternCtorArg - { _index = Index.ZeroBased i - , _type = paramType - , _arg = pvar (Data.Name.fromChars $ "v" ++ show i) - } - ) - - paramEncoders = - paramTypes & imap (\i paramType -> - encodeTypeValue 0 ifaces cname paramType (lvar (Data.Name.fromChars $ "v" ++ show i)) - ) - in - CaseBranch - (a (PCtor - { _p_home = cname - , _p_type = unionName - , _p_union = union - , _p_name = tagName - , _p_index = tagIndex - , _p_args = params - })) - (encodeSequenceWithoutLength $ list $ [ encodeUnsignedInt8 (int i) ] ++ paramEncoders) - ) - ) - in - generated - - -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 = - let - !x = runTests isTest "decoderUnion" pkg modul decls generatedName generated union (unionAsModule cname unionName union) - - generatedName = Data.Name.fromChars $ "w2_decode_" ++ Data.Name.toChars unionName - cname = Module.Canonical pkg (Src.getName modul) - tvars = _u_vars union - tvarsTypesig = tvars & foldl (\acc name -> Map.insert name () acc ) Map.empty - ptvars = tvars & fmap (\tvar -> pvar $ Data.Name.fromChars $ "w2_x_c_" ++ Data.Name.toChars tvar ) - unionType = TType cname unionName (fmap TVar tvars) - - vctor :: Data.Name.Name -> Index.ZeroBased -> [Type] -> Expr - vctor tagName index paramTypes = - let - constructorType = paramTypes & foldr (\paramType typeSig -> TLambda paramType typeSig ) unionType - in - (a (VarCtor (_u_opts union) cname tagName index (Forall tvarsTypesig constructorType))) - - generated = - Def - -- TypedDef - (a (generatedName)) - -- Map.empty - ptvars $ - -- debugDecoder (Data.Name.toElmString unionName) - (decodeUnsignedInt8 |> andThenDecode1 - (lambda1 (pvar "w2v") $ - caseof (lvar "w2v") $ - _u_alts union - & List.sortOn (\(Ctor name index_ numParams paramTypes) -> name) - & imap (\i (Ctor tagName tagIndex numParams paramTypes) -> - CaseBranch (pint i) $ - ([(succeedDecode (vctor tagName tagIndex paramTypes))] - ++ fmap (\paramType -> andMapDecode1 ((decoderForType ifaces cname paramType))) paramTypes) - & foldlPairs (|>) - ) - & (\l -> l ++ [CaseBranch pAny_ $ failDecode (Data.Name.toChars generatedName <> " unexpected union tag index")]) - ) - ) - -- (TAlias - -- (Module.Canonical (Name "lamdera" "codecs") "Lamdera.Wire2") - -- "Decoder" - -- [("a", unionType)] - -- (Holey (TType (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" [TVar "a"]))) - in - generated - - -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) = - let - !x = runTests isTest "encoderAlias" pkg modul decls generatedName generated alias (aliasAsModule cname aliasName alias) - - generatedName = Data.Name.fromChars $ "w2_encode_" ++ Data.Name.toChars aliasName - cname = Module.Canonical pkg (Src.getName modul) - ptvars = tvars & fmap (\tvar -> pvar $ Data.Name.fromChars $ "w2_x_c_" ++ Data.Name.toChars tvar ) - - generated = Def (a (generatedName)) ptvars $ - -- debugEncoder (Data.Name.toElmString aliasName) $ - deepEncoderForType 0 ifaces cname tipe - in - generated - - -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) = - let - !x = runTests isTest "decoderAlias" pkg modul decls generatedName generated alias (aliasAsModule cname aliasName alias) - - generatedName = Data.Name.fromChars $ "w2_decode_" ++ Data.Name.toChars aliasName - cname = Module.Canonical pkg (Src.getName modul) - ptvars = tvars & fmap (\tvar -> pvar $ Data.Name.fromChars $ "w2_x_c_" ++ Data.Name.toChars tvar ) - - generated = Def (a (generatedName)) ptvars $ - -- debugDecoder (Data.Name.toElmString aliasName) $ - decoderForType ifaces cname tipe - in - generated diff --git a/extra/Lamdera/Wire2/Decoder.hs b/extra/Lamdera/Wire2/Decoder.hs deleted file mode 100644 index 59df008eb..000000000 --- a/extra/Lamdera/Wire2/Decoder.hs +++ /dev/null @@ -1,377 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE BangPatterns #-} - -module Lamdera.Wire2.Decoder where - -import System.IO.Unsafe (unsafePerformIO) -import qualified Data.Map as Map -import qualified Data.List as List -import qualified Data.Graph as Graph - -import Elm.Package -import qualified AST.Source as Src -import qualified Elm.Interface as I -import qualified Elm.ModuleName as Module -import qualified Elm.Package as Pkg -import qualified AST.Canonical as Can -import AST.Canonical -import qualified Data.Name -import qualified Data.Utf8 as Utf8 -import qualified Reporting.Annotation as A -import qualified Reporting.Error as E -import qualified Reporting.Doc as D -import qualified Data.Text as T -import qualified Data.Index as Index - - -import Lamdera -import StandaloneInstances -import qualified CanSer.CanSer as ToSource - -import Lamdera.Wire2.Helpers - - -callDecoder :: Data.Name.Name -> Type -> Expr -callDecoder name tipe = - (a (VarForeign mLamdera_Wire2 name (Forall Map.empty (TAlias mLamdera_Wire2 "Decoder" [("a", tipe)] (Filled (TType (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" [tipe])))))) - - -decoderForType :: Map.Map Module.Raw I.Interface -> Module.Canonical -> Type -> Expr -decoderForType ifaces cname tipe = - case tipe of - (TType (Module.Canonical (Name "elm" "core") "Basics") "Int" []) -> callDecoder "decodeInt" tipe - (TType (Module.Canonical (Name "elm" "core") "Basics") "Float" []) -> callDecoder "decodeFloat" tipe - (TType (Module.Canonical (Name "elm" "core") "Basics") "Bool" []) -> callDecoder "decodeBool" tipe - (TType (Module.Canonical (Name "elm" "core") "Basics") "Order" []) -> callDecoder "decodeOrder" tipe - (TType (Module.Canonical (Name "elm" "core") "Basics") "Never" []) -> callDecoder "decodeNever" tipe - (TType (Module.Canonical (Name "elm" "core") "Char") "Char" []) -> callDecoder "decodeChar" tipe - (TType (Module.Canonical (Name "elm" "core") "String") "String" []) -> callDecoder "decodeString" tipe - - TUnit -> callDecoder "decodeUnit" tipe - - TTuple a_ b Nothing -> - (a (Call - (a (VarForeign - (Module.Canonical (Name "lamdera" "codecs") "Lamdera.Wire2") - "decodePair" - (Forall - (Map.fromList [("a", ()), ("b", ())]) - (TLambda - (TAlias - (Module.Canonical (Name "lamdera" "codecs") "Lamdera.Wire2") - "Decoder" - [("a", TVar "a")] - (Filled - (TType - (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") - "Decoder" - [TVar "a"]))) - (TLambda - (TAlias - (Module.Canonical (Name "lamdera" "codecs") "Lamdera.Wire2") - "Decoder" - [("a", TVar "b")] - (Filled - (TType - (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") - "Decoder" - [TVar "b"]))) - (TAlias - (Module.Canonical (Name "lamdera" "codecs") "Lamdera.Wire2") - "Decoder" - [("a", TTuple (TVar "a") (TVar "b") Nothing)] - (Filled - (TType - (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") - "Decoder" - [TTuple (TVar "a") (TVar "b") Nothing])))))))) - [ decoderForType ifaces cname a_ - , decoderForType ifaces cname b - ])) - - TTuple a_ b (Just c) -> - (a (Call - (a (VarForeign - (Module.Canonical (Name "lamdera" "codecs") "Lamdera.Wire2") - "decodeTriple" - (Forall - (Map.fromList [("a", ()), ("b", ()), ("c", ())]) - (TLambda - (TAlias (Module.Canonical (Name "lamdera" "codecs") "Lamdera.Wire2") "Decoder" [("a", TVar "a")] - (Filled - (TType - (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") - "Decoder" - [TVar "a"]))) - (TLambda - (TAlias (Module.Canonical (Name "lamdera" "codecs") "Lamdera.Wire2") "Decoder" [("a", TVar "b")] - (Filled - (TType - (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") - "Decoder" - [TVar "b"]))) - (TLambda - (TAlias (Module.Canonical (Name "lamdera" "codecs") "Lamdera.Wire2") "Decoder" [("a", TVar "c")] - (Filled - (TType - (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") - "Decoder" - [TVar "c"]))) - (TAlias (Module.Canonical (Name "lamdera" "codecs") "Lamdera.Wire2") "Decoder" - [("a", TTuple (TVar "a") (TVar "b") (Just (TVar "c")))] - (Filled - (TType (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" - [TTuple (TVar "a") (TVar "b") (Just (TVar "c"))]))))))))) - [ decoderForType ifaces cname a_ - , decoderForType ifaces cname b - , decoderForType ifaces cname c - ])) - - TType (Module.Canonical (Name "elm" "core") "Maybe") "Maybe" [ptype] -> - (a (Call - (a (VarForeign mLamdera_Wire2 "decodeMaybe" - (Forall - (Map.fromList [("a", ())]) - (TLambda - (TAlias mLamdera_Wire2 "Decoder" [("a", TVar "a")] - (Filled (TType (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" [TVar "a"]))) - (TAlias - mLamdera_Wire2 - "Decoder" - [("a", TType (Module.Canonical (Name "elm" "core") "Maybe") "Maybe" [TVar "a"])] - (Filled - (TType - (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") - "Decoder" - [TType (Module.Canonical (Name "elm" "core") "Maybe") "Maybe" [TVar "a"]]))))))) - [ decoderForType ifaces cname ptype ])) - - TType (Module.Canonical (Name "elm" "core") "List") "List" [ptype] -> - (a (Call - (a (VarForeign mLamdera_Wire2 "decodeList" - (Forall - (Map.fromList [("a", ())]) - (TLambda - (TAlias mLamdera_Wire2 "Decoder" [("a", TVar "a")] - (Filled (TType (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" [TVar "a"]))) - (TAlias - mLamdera_Wire2 - "Decoder" - [("a", TType (Module.Canonical (Name "elm" "core") "List") "List" [TVar "a"])] - (Filled - (TType - (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") - "Decoder" - [TType (Module.Canonical (Name "elm" "core") "List") "List" [TVar "a"]]))))))) - [ decoderForType ifaces cname ptype ])) - - TType (Module.Canonical (Name "elm" "core") "Set") "Set" [ptype] -> - (a (Call - (a (VarForeign mLamdera_Wire2 "decodeSet" - (Forall - (Map.fromList [("comparable", ())]) - (TLambda - (TAlias mLamdera_Wire2 "Decoder" [("a", TVar "comparable")] - (Filled (TType (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" [TVar "comparable"]))) - (TAlias - mLamdera_Wire2 - "Decoder" - [("a", TType (Module.Canonical (Name "elm" "core") "Set") "Set" [TVar "comparable"])] - (Filled - (TType - (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") - "Decoder" - [TType (Module.Canonical (Name "elm" "core") "Set") "Set" [TVar "comparable"]]))))))) - [ decoderForType ifaces cname ptype ])) - - TType (Module.Canonical (Name "elm" "core") "Array") "Array" [ptype] -> - (a (Call - (a (VarForeign mLamdera_Wire2 "decodeArray" - (Forall - (Map.fromList [("a", ())]) - (TLambda - (TAlias mLamdera_Wire2 "Decoder" [("a", TVar "a")] - (Filled (TType (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" [TVar "a"]))) - (TAlias - mLamdera_Wire2 - "Decoder" - [("a", TType (Module.Canonical (Name "elm" "core") "Array") "Array" [TVar "a"])] - (Filled - (TType - (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") - "Decoder" - [TType (Module.Canonical (Name "elm" "core") "Array") "Array" [TVar "a"]]))))))) - [ decoderForType ifaces cname ptype ])) - - TType (Module.Canonical (Name "elm" "core") "Result") "Result" [err, a_] -> - (a (Call - (a (VarForeign mLamdera_Wire2 "decodeResult" - (Forall - (Map.fromList [("err", ()), ("val", ())]) - (TLambda - (TAlias mLamdera_Wire2 "Decoder" [("a", TVar "err")] - (Filled - (TType - (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") - "Decoder" - [TVar "err"]))) - (TLambda (TAlias mLamdera_Wire2 "Decoder" [("a", TVar "val")] - (Filled - (TType - (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") - "Decoder" - [TVar "val"]))) - (TAlias mLamdera_Wire2 "Decoder" [ ( "a" - , TType - (Module.Canonical (Name "elm" "core") "Result") - "Result" - [TVar "err", TVar "val"]) - ] - (Filled - (TType - (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") - "Decoder" - [ TType - (Module.Canonical (Name "elm" "core") "Result") - "Result" - [TVar "err", TVar "val"] - ])))))))) - [ decoderForType ifaces cname err - , decoderForType ifaces cname a_ - ])) - - TType (Module.Canonical (Name "elm" "core") "Dict") "Dict" [key, val] -> - (a (Call - (a (VarForeign mLamdera_Wire2 "decodeDict" - (Forall - (Map.fromList [("comparable", ()), ("value", ())]) - (TLambda - (TAlias mLamdera_Wire2 "Decoder" [("a", TVar "comparable")] - (Filled - (TType - (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") - "Decoder" - [TVar "comparable"]))) - (TLambda - (TAlias mLamdera_Wire2 "Decoder" [("a", TVar "value")] - (Filled - (TType - (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") - "Decoder" - [TVar "value"]))) - (TAlias mLamdera_Wire2 "Decoder" - [ ( "a" - , TType - (Module.Canonical (Name "elm" "core") "Dict") - "Dict" - [TVar "comparable", TVar "value"]) - ] - (Filled - (TType - (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") - "Decoder" - [ TType - (Module.Canonical (Name "elm" "core") "Dict") - "Dict" - [TVar "comparable", TVar "value"] - ])))))))) - [ decoderForType ifaces cname key - , decoderForType ifaces cname val - ])) - - TType (Module.Canonical (Name "elm" "bytes") "Bytes") "Bytes" _ -> - callDecoder "decodeBytes" tipe - - TType (Module.Canonical (Name "elm" "time") "Time") "Posix" params -> - decodeTime - - - -- Frontend only JS reference types - TType (Module.Canonical (Name "elm" "file") "File") "File" params -> callDecoder "decodeRef" tipe - - - TType moduleName typeName params -> - let - generatedName = Data.Name.fromChars $ "w2_decode_" ++ Data.Name.toChars typeName - - decoder = - if cname == moduleName - -- Referenced type is defined in the current module - then (a (VarTopLevel moduleName generatedName)) - else (a (VarForeign moduleName generatedName (getForeignSig tipe moduleName generatedName ifaces))) - in - if isUnsupportedKernelType tipe - then failDecode (Data.Name.toChars generatedName <> " isUnsupportedKernelType") - else - case params of - [] -> decoder - _ -> call decoder $ fmap (decoderForType ifaces cname) params - - TRecord fieldMap maybeExtensible -> - -- | TRecord (Map.Map Name FieldType) (Maybe Name) - case maybeExtensible of - Just extensibleName -> - -- @EXTENSIBLERECORDS not supported yet - failDecode $ "extensible record" -- <> Data.Name.toChars extensibleName - Nothing -> - let fields = fieldMap & fieldsToList - in - decodeRecord ifaces cname fields - - TAlias moduleName typeName tvars_ aType -> - let - generatedName = Data.Name.fromChars $ "w2_decode_" ++ Data.Name.toChars typeName - - decoder = - if cname == moduleName - -- Referenced type is defined in the current module - then (a (VarTopLevel moduleName generatedName)) - -- Referenced type is defined in another module - else (a (VarForeign moduleName generatedName (getForeignSig tipe moduleName generatedName ifaces))) - - in - if isUnsupportedKernelType tipe - then failDecode (Data.Name.toChars generatedName <> " isUnsupportedKernelType") - else - case tvars_ of - [] -> decoder - _ -> - call decoder $ fmap (\(tvarName, tvarType) -> - case tvarType of - TVar name -> - lvar $ Data.Name.fromChars $ "w2_x_c_" ++ Data.Name.toChars name - _ -> - decoderForType ifaces cname tvarType - ) tvars_ - - TVar name -> - lvar $ Data.Name.fromChars $ "w2_x_c_" ++ Data.Name.toChars name - - TLambda t1 t2 -> - failDecode "lambda" - - -decodeRecord :: Map.Map Module.Raw I.Interface -> Module.Canonical -> [(Data.Name.Name, Type)] -> Expr -decodeRecord ifaces cname fields = - let - pvars :: [Pattern] - pvars = - (imap (\i (name, field) -> a (PVar $ Data.Name.fromChars $ Data.Name.toChars name ++ "0")) fields) - - newRecFields :: Map.Map Data.Name.Name Expr - newRecFields = - fields - & fmap (\(name, field) -> - (name, a (VarLocal $ Data.Name.fromChars $ Data.Name.toChars name ++ "0")) - ) - & Map.fromList - in - [succeedDecode (a (Lambda pvars (a (Record newRecFields ))))] - ++ fmap (\(name, field) -> - andMapDecode1 ( - -- debugDecoder (Utf8.fromChars $ "." <> Data.Name.toChars name) $ - decoderForType ifaces cname field - ) - ) fields - & foldlPairs (|>) diff --git a/extra/Lamdera/Wire2/Encoder.hs b/extra/Lamdera/Wire2/Encoder.hs deleted file mode 100644 index 8a337df7f..000000000 --- a/extra/Lamdera/Wire2/Encoder.hs +++ /dev/null @@ -1,382 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE BangPatterns #-} - -module Lamdera.Wire2.Encoder where - -import System.IO.Unsafe (unsafePerformIO) -import qualified Data.Map as Map -import qualified Data.List as List -import qualified Data.Graph as Graph - -import Elm.Package -import qualified AST.Source as Src -import qualified Elm.Interface as I -import qualified Elm.ModuleName as Module -import qualified Elm.Package as Pkg -import qualified AST.Canonical as Can -import AST.Canonical -import qualified Data.Name -import qualified Data.Utf8 as Utf8 -import qualified Reporting.Annotation as A -import qualified Reporting.Error as E -import qualified Reporting.Doc as D -import qualified Data.Text as T -import qualified Data.Index as Index - - -import Lamdera -import StandaloneInstances -import qualified CanSer.CanSer as ToSource - -import Lamdera.Wire2.Helpers - - -encoderNotImplemented tag tipe = - error $ tag ++ " not implemented! " ++ show tipe - -- str $ Utf8.fromChars $ tag ++ " not implemented! " ++ show tipe - - -encoderForType depth ifaces cname tipe = - case tipe of - (TType (Module.Canonical (Name "elm" "core") "Basics") "Int" []) -> - (a (VarForeign mLamdera_Wire2 "encodeInt" (Forall Map.empty (TLambda tipe tLamdera_Wire2__Encoder)))) - - (TType (Module.Canonical (Name "elm" "core") "Basics") "Float" []) -> - (a (VarForeign mLamdera_Wire2 "encodeFloat" (Forall Map.empty (TLambda tipe tLamdera_Wire2__Encoder)))) - - (TType (Module.Canonical (Name "elm" "core") "Basics") "Bool" []) -> - (a (VarForeign mLamdera_Wire2 "encodeBool" (Forall Map.empty (TLambda tipe tLamdera_Wire2__Encoder)))) - - (TType (Module.Canonical (Name "elm" "core") "Basics") "Order" []) -> - (a (VarForeign mLamdera_Wire2 "encodeOrder" (Forall Map.empty (TLambda tipe tLamdera_Wire2__Encoder)))) - - (TType (Module.Canonical (Name "elm" "core") "Basics") "Never" []) -> - -- @OPTIMIZE remove this, should just encodeFail... - (a (VarForeign mLamdera_Wire2 "encodeNever" (Forall Map.empty (TLambda tipe tLamdera_Wire2__Encoder)))) - - (TType (Module.Canonical (Name "elm" "core") "Char") "Char" []) -> - (a (VarForeign mLamdera_Wire2 "encodeChar" (Forall Map.empty (TLambda tipe tLamdera_Wire2__Encoder)))) - - (TType (Module.Canonical (Name "elm" "core") "String") "String" []) -> - (a (VarForeign mLamdera_Wire2 "encodeString" (Forall Map.empty (TLambda tipe tLamdera_Wire2__Encoder)))) - - TUnit -> - (a (VarForeign mLamdera_Wire2 "encodeUnit" (Forall Map.empty (TLambda TUnit tLamdera_Wire2__Encoder)))) - - TTuple a_ b Nothing -> - (a (VarForeign mLamdera_Wire2 "encodePair" - (Forall - (Map.fromList [("a", ()), ("b", ())]) - (TLambda - (TLambda (TVar "a") tLamdera_Wire2__Encoder) - (TLambda - (TLambda (TVar "b") tLamdera_Wire2__Encoder) - (TLambda - (TTuple (TVar "a") (TVar "b") Nothing) - tLamdera_Wire2__Encoder)))))) - - TTuple a_ b (Just c) -> - (a (VarForeign mLamdera_Wire2 "encodeTriple" - (Forall - (Map.fromList [("a", ()), ("b", ()), ("c", ())]) - (TLambda - (TLambda (TVar "a") tLamdera_Wire2__Encoder) - (TLambda - (TLambda (TVar "b") tLamdera_Wire2__Encoder) - (TLambda - (TLambda (TVar "c") tLamdera_Wire2__Encoder) - (TLambda - (TTuple (TVar "a") (TVar "b") (Just (TVar "c"))) - tLamdera_Wire2__Encoder))))))) - - TType (Module.Canonical (Name "elm" "core") "Maybe") "Maybe" [ptype] -> - (a (VarForeign mLamdera_Wire2 "encodeMaybe" - (Forall - (Map.fromList [("a", ())]) - (TLambda - (TLambda (TVar "a") tLamdera_Wire2__Encoder) - (TLambda - (TType (Module.Canonical (Name "elm" "core") "Maybe") "Maybe" [TVar "a"]) - tLamdera_Wire2__Encoder))))) - - TType (Module.Canonical (Name "elm" "core") "List") "List" [ptype] -> - (a (VarForeign mLamdera_Wire2 "encodeList" - (Forall - (Map.fromList [("a", ())]) - (TLambda - (TLambda (TVar "a") tLamdera_Wire2__Encoder) - (TLambda - (TType (Module.Canonical (Name "elm" "core") "List") "List" [TVar "a"]) - tLamdera_Wire2__Encoder))))) - - TType (Module.Canonical (Name "elm" "core") "Set") "Set" [ptype] -> - (a (VarForeign mLamdera_Wire2 "encodeSet" - (Forall - (Map.fromList [("value", ())]) - (TLambda - (TLambda (TVar "value") tLamdera_Wire2__Encoder) - (TLambda - (TType (Module.Canonical (Name "elm" "core") "Set") "Set" [TVar "value"]) - tLamdera_Wire2__Encoder))))) - - TType (Module.Canonical (Name "elm" "core") "Array") "Array" [ptype] -> - (a (VarForeign mLamdera_Wire2 "encodeArray" - (Forall - (Map.fromList [("a", ())]) - (TLambda - (TLambda (TVar "a") tLamdera_Wire2__Encoder) - (TLambda - (TType (Module.Canonical (Name "elm" "core") "Array") "Array" [TVar "a"]) - tLamdera_Wire2__Encoder))))) - - TType (Module.Canonical (Name "elm" "core") "Result") "Result" [err, a_] -> - (a (VarForeign mLamdera_Wire2 "encodeResult" - (Forall - (Map.fromList [("err", ()), ("val", ())]) - (TLambda - (TLambda (TVar "err") tLamdera_Wire2__Encoder) - (TLambda (TLambda (TVar "val") tLamdera_Wire2__Encoder) - (TLambda - (TType (Module.Canonical (Name "elm" "core") "Result") "Result" [TVar "err", TVar "val"]) - tLamdera_Wire2__Encoder)))))) - - TType (Module.Canonical (Name "elm" "core") "Dict") "Dict" [key, value] -> - (a (VarForeign mLamdera_Wire2 "encodeDict" - (Forall - (Map.fromList [("key", ()), ("value", ())]) - (TLambda - (TLambda (TVar "key") tLamdera_Wire2__Encoder) - (TLambda (TLambda (TVar "value") tLamdera_Wire2__Encoder) - (TLambda - (TType (Module.Canonical (Name "elm" "core") "Dict") "Dict" [TVar "key", TVar "value"]) - tLamdera_Wire2__Encoder)))))) - - - TType (Module.Canonical (Name "elm" "bytes") "Bytes") "Bytes" _ -> - (a (VarForeign mLamdera_Wire2 "encodeBytes" (Forall Map.empty (TLambda tipe tLamdera_Wire2__Encoder)))) - - - TType (Module.Canonical (Name "elm" "time") "Time") "Posix" _ -> - (a (Lambda - [(a (PVar "t"))] - (a (Call - (a (VarForeign - (Module.Canonical (Name "lamdera" "codecs") "Lamdera.Wire2") - "encodeInt" - (Forall - (Map.fromList []) - (TLambda - (TType (Module.Canonical (Name "elm" "core") "Basics") "Int" []) - (TAlias - (Module.Canonical (Name "lamdera" "codecs") "Lamdera.Wire2") - "Encoder" - [] - (Filled (TType (Module.Canonical (Name "elm" "bytes") "Bytes.Encode") "Encoder" []))))))) - [ (a (Call - (a (VarForeign - (Module.Canonical (Name "elm" "time") "Time") - "posixToMillis" - (Forall - (Map.fromList []) - (TLambda - (TType (Module.Canonical (Name "elm" "time") "Time") "Posix" []) - (TType (Module.Canonical (Name "elm" "core") "Basics") "Int" []))))) - [(a (VarLocal "t"))])) - ])))) - - - -- Frontend only JS reference types - TType (Module.Canonical (Name "elm" "file") "File") "File" _ -> - (a (VarForeign mLamdera_Wire2 "encodeRef" (Forall Map.empty (TLambda tipe tLamdera_Wire2__Encoder)))) - - - TType moduleName typeName params -> - let - generatedName = Data.Name.fromChars $ "w2_encode_" ++ Data.Name.toChars typeName - - decoder = - if cname == moduleName - -- Referenced type is defined in the current module - then (a (VarTopLevel moduleName generatedName)) - else (a (VarForeign moduleName generatedName (getForeignSig tipe moduleName generatedName ifaces))) - - in - if isUnsupportedKernelType tipe - then failEncode - else decoder - - - TRecord fieldMap maybeExtensible -> - case maybeExtensible of - Just extensibleName -> - -- @EXTENSIBLERECORDS not supported yet - failEncode - - Nothing -> - let - fields = fieldsToList fieldMap - fieldEncoders = - fields - & fmap (\(name, field) -> - -- debugEncoder_ (Utf8.fromChars $ "." <> Data.Name.toChars name) $ - encodeTypeValue (depth + 1) ifaces cname field (a (Access (a (VarLocal $ Utf8.fromChars $ "w2_rec_var" ++ show depth)) (a (name)))) - ) - in - (a (Lambda [(a (PVar $ Utf8.fromChars $ "w2_rec_var" ++ show depth))] - (encodeSequenceWithoutLength $ list fieldEncoders) - )) - - - - TAlias moduleName typeName tvars_ aType -> - let - generatedName = Data.Name.fromChars $ "w2_encode_" ++ Data.Name.toChars typeName - - encoder = - if cname == moduleName - -- Referenced type is defined in the current module - then (a (VarTopLevel moduleName generatedName)) - -- Referenced type is defined in another module - else (a (VarForeign moduleName generatedName (getForeignSig tipe moduleName generatedName ifaces))) - in - if isUnsupportedKernelType tipe - then failEncode - else encoder - - - TVar name -> - -- Tvars should always have a local encoder in scope - lvar $ Data.Name.fromChars $ "w2_x_c_" ++ Data.Name.toChars name - - TLambda t1 t2 -> - failEncode - - -deepEncoderForType depth ifaces cname tipe = - case tipe of - TType (Module.Canonical (Name "elm" "core") "Basics") "Int" [] -> encoderForType depth ifaces cname tipe - TType (Module.Canonical (Name "elm" "core") "Basics") "Float" [] -> encoderForType depth ifaces cname tipe - TType (Module.Canonical (Name "elm" "core") "Basics") "Bool" [] -> encoderForType depth ifaces cname tipe - TType (Module.Canonical (Name "elm" "core") "Basics") "Order" [] -> encoderForType depth ifaces cname tipe - TType (Module.Canonical (Name "elm" "core") "Basics") "Never" [] -> encoderForType depth ifaces cname tipe - TType (Module.Canonical (Name "elm" "core") "Char") "Char" [] -> encoderForType depth ifaces cname tipe - TType (Module.Canonical (Name "elm" "core") "String") "String" [] -> encoderForType depth ifaces cname tipe - TUnit -> encoderForType depth ifaces cname tipe - - TTuple a b Nothing -> call (encoderForType depth ifaces cname tipe) [ deepEncoderForType depth ifaces cname a, deepEncoderForType depth ifaces cname b ] - TTuple a b (Just c) -> call (encoderForType depth ifaces cname tipe) [ deepEncoderForType depth ifaces cname a, deepEncoderForType depth ifaces cname b, deepEncoderForType depth ifaces cname c ] - - TType (Module.Canonical (Name "elm" "core") "Maybe") "Maybe" [a] -> call (encoderForType depth ifaces cname tipe) [ deepEncoderForType depth ifaces cname a ] - TType (Module.Canonical (Name "elm" "core") "List") "List" [a] -> call (encoderForType depth ifaces cname tipe) [ deepEncoderForType depth ifaces cname a ] - TType (Module.Canonical (Name "elm" "core") "Set") "Set" [a] -> call (encoderForType depth ifaces cname tipe) [ deepEncoderForType depth ifaces cname a ] - TType (Module.Canonical (Name "elm" "core") "Array") "Array" [a] -> call (encoderForType depth ifaces cname tipe) [ deepEncoderForType depth ifaces cname a ] - - TType (Module.Canonical (Name "elm" "core") "Result") "Result" [err, a] -> - call (encoderForType depth ifaces cname tipe) [ deepEncoderForType depth ifaces cname err, deepEncoderForType depth ifaces cname a ] - - TType (Module.Canonical (Name "elm" "core") "Dict") "Dict" [key, val] -> - call (encoderForType depth ifaces cname tipe) [ deepEncoderForType depth ifaces cname key, deepEncoderForType depth ifaces cname val ] - - TType (Module.Canonical (Name "elm" "bytes") "Bytes") "Bytes" _ -> encoderForType depth ifaces cname tipe - TType (Module.Canonical (Name "elm" "time") "Time") "Posix" _ -> encoderForType depth ifaces cname tipe - - -- Frontend only JS reference types - TType (Module.Canonical (Name "elm" "file") "File") "File" _ -> encoderForType depth ifaces cname tipe - - - TType moduleName typeName params -> - if isUnsupportedKernelType tipe - then failEncode - else - case params of - [] -> encoderForType depth ifaces cname tipe - _ -> - call (encoderForType depth ifaces cname tipe) $ fmap (\tvarType -> - case tvarType of - TVar name -> - lvar $ Data.Name.fromChars $ "w2_x_c_" ++ Data.Name.toChars name - _ -> - deepEncoderForType depth ifaces cname tvarType - ) params - - - TRecord fieldMap maybeName -> - encoderForType depth ifaces cname tipe - - TAlias moduleName typeName tvars aType -> - if isUnsupportedKernelType tipe - then failEncode - else - case tvars of - [] -> encoderForType depth ifaces cname tipe - _ -> - call (encoderForType depth ifaces cname tipe) $ fmap (\(tvarName, tvarType) -> - case tvarType of - TVar name -> - lvar $ Data.Name.fromChars $ "w2_x_c_" ++ Data.Name.toChars name - _ -> - deepEncoderForType depth ifaces cname tvarType - ) tvars - - TVar name -> encoderForType depth ifaces cname tipe - TLambda t1 t2 -> encoderForType depth ifaces cname tipe - - -encodeTypeValue depth ifaces cname tipe value = - case tipe of - (TType (Module.Canonical (Name "elm" "core") "Basics") "Int" []) -> call (encoderForType depth ifaces cname tipe) [ value ] - (TType (Module.Canonical (Name "elm" "core") "Basics") "Float" []) -> call (encoderForType depth ifaces cname tipe) [ value ] - (TType (Module.Canonical (Name "elm" "core") "Basics") "Bool" []) -> call (encoderForType depth ifaces cname tipe) [ value ] - (TType (Module.Canonical (Name "elm" "core") "Basics") "Order" []) -> call (encoderForType depth ifaces cname tipe) [ value ] - (TType (Module.Canonical (Name "elm" "core") "Basics") "Never" []) -> call (encoderForType depth ifaces cname tipe) [ value ] - (TType (Module.Canonical (Name "elm" "core") "Char") "Char" []) -> call (encoderForType depth ifaces cname tipe) [ value ] - (TType (Module.Canonical (Name "elm" "core") "String") "String" []) -> call (encoderForType depth ifaces cname tipe) [ value ] - TUnit -> call (encoderForType depth ifaces cname tipe) [ value ] - - TTuple a b Nothing -> call (encoderForType depth ifaces cname tipe) [ deepEncoderForType depth ifaces cname a, deepEncoderForType depth ifaces cname b, value ] - TTuple a b (Just c) -> call (encoderForType depth ifaces cname tipe) [ deepEncoderForType depth ifaces cname a, deepEncoderForType depth ifaces cname b, deepEncoderForType depth ifaces cname c, value ] - - TType (Module.Canonical (Name "elm" "core") "Maybe") "Maybe" [a] -> call (encoderForType depth ifaces cname tipe) [ deepEncoderForType depth ifaces cname a, value ] - TType (Module.Canonical (Name "elm" "core") "List") "List" [a] -> call (encoderForType depth ifaces cname tipe) [ deepEncoderForType depth ifaces cname a, value ] - TType (Module.Canonical (Name "elm" "core") "Set") "Set" [a] -> call (encoderForType depth ifaces cname tipe) [ deepEncoderForType depth ifaces cname a, value ] - TType (Module.Canonical (Name "elm" "core") "Array") "Array" [a] -> call (encoderForType depth ifaces cname tipe) [ deepEncoderForType depth ifaces cname a, value ] - - TType (Module.Canonical (Name "elm" "core") "Result") "Result" [err, a] -> - call (encoderForType depth ifaces cname tipe) [ deepEncoderForType depth ifaces cname err, deepEncoderForType depth ifaces cname a, value ] - - TType (Module.Canonical (Name "elm" "core") "Dict") "Dict" [key, val] -> - call (encoderForType depth ifaces cname tipe) [ deepEncoderForType depth ifaces cname key, deepEncoderForType depth ifaces cname val, value ] - - TType (Module.Canonical (Name "elm" "bytes") "Bytes") "Bytes" _ -> call (encoderForType depth ifaces cname tipe) [ value ] - TType (Module.Canonical (Name "elm" "time") "Time") "Posix" _ -> call (encoderForType depth ifaces cname tipe) [ value ] - - -- Frontend only JS reference types - TType (Module.Canonical (Name "elm" "file") "File") "File" _ -> call (encoderForType depth ifaces cname tipe) [ value ] - - - TType moduleName typeName params -> - if isUnsupportedKernelType tipe - then call failEncode [ a Unit ] - else call (encoderForType depth ifaces cname tipe) $ fmap (deepEncoderForType depth ifaces cname) params ++ [ value ] - - TRecord fieldMap maybeExtensible -> - case maybeExtensible of - Just extensibleName -> - -- @EXTENSIBLERECORDS not supported yet - call failEncode [ a Unit ] - - Nothing -> - call (encoderForType depth ifaces cname tipe) [ value ] - - TAlias moduleName typeName tvars aType -> - if isUnsupportedKernelType tipe - then call failEncode [ a Unit ] - else call (encoderForType depth ifaces cname tipe) $ fmap (\(tvarName, tvarType) -> deepEncoderForType depth ifaces cname tvarType) tvars ++ [ value ] - - TVar name -> - -- Tvars should always have a local encoder in scope - call (lvar $ Data.Name.fromChars $ "w2_x_c_" ++ Data.Name.toChars name) [value] - - TLambda t1 t2 -> - call failEncode [ a Unit ] diff --git a/extra/Lamdera/Wire2/Graph.hs b/extra/Lamdera/Wire2/Graph.hs deleted file mode 100644 index 6a18d733d..000000000 --- a/extra/Lamdera/Wire2/Graph.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Lamdera.Wire2.Graph where - -import qualified Data.Map as Map -import qualified Data.Graph as Graph - -import qualified Data.Name -import AST.Canonical -import qualified Reporting.Annotation as A - -import Lamdera -import Lamdera.Wire2.Helpers - - --- The Decls data structure must be topologically sorted by LocalVar refs, --- otherwise type inference will throw Map.! errors and not be able to see sub-functions -stronglyConnCompDefs defs = - defs - & fmap defToNode - & Graph.stronglyConnComp - - -addGraphDefsToDecls decls defsGraph = - defsGraph - & foldr (\scc decls -> - case scc of - Graph.AcyclicSCC def -> - addDef def decls - Graph.CyclicSCC defs -> - addRecDef defs decls - ) decls - - -defToNode :: Def -> (Def, Data.Name.Name, [Data.Name.Name]) -defToNode def = - ( def, defName def, defGetEdges def ) - - -defGetEdges :: Def -> [Data.Name.Name] -defGetEdges def = - case def of - Def (A.At region name_) pvars expr -> - getLvars expr - TypedDef (A.At region name_) freeVars pvars expr tipe -> - getLvars expr - - -getLvars :: Expr -> [Data.Name.Name] -getLvars (A.At _ expr_) = - case expr_ of - VarLocal name -> [] - VarTopLevel cname name -> [name] - VarKernel module_ name -> [] - VarForeign cname name annotation -> [] - VarCtor ctorOpts cname name index annotation -> [] - VarDebug cname name annotation -> [] - VarOperator name cname name2 annotation -> [] - Chr s -> [] - Str s -> [] - Int i -> [] - Float f -> [] - List exprs -> exprs & concatMap getLvars - Negate expr -> getLvars expr - Binop name cname name2 annotation e1 e2 -> [e1, e2] & concatMap getLvars - Lambda pvars expr -> getLvars expr - Call expr params -> getLvars expr ++ concatMap getLvars params - If [(e1, e2)] e3 -> [e1, e2, e3] & concatMap getLvars - Let def expr -> defGetEdges def ++ getLvars expr - LetRec defs expr -> concatMap defGetEdges defs ++ getLvars expr - LetDestruct pat e1 e2 -> [e1, e2] & concatMap getLvars - Case expr branches -> branches & concatMap (\(CaseBranch pat expr) -> getLvars expr) - Accessor name -> [] - Access expr aName -> getLvars expr - Update name expr fieldUpdates -> getLvars expr ++ - (fieldUpdates & Map.toList & concatMap (\(n, (FieldUpdate region expr)) -> getLvars expr)) - Record fields -> - fields & Map.toList & concatMap (\(n, expr) -> getLvars expr) - Unit -> [] - Tuple e1 e2 me3 -> - case me3 of - Just e3 -> [e1, e2, e3] & concatMap getLvars - Nothing -> [e1, e2] & concatMap getLvars - Shader source types -> [] - _ -> error $ "getLvars: impossible expr: " ++ show expr_ diff --git a/extra/Lamdera/Wire2/Helpers.hs b/extra/Lamdera/Wire2/Helpers.hs deleted file mode 100644 index 65472a791..000000000 --- a/extra/Lamdera/Wire2/Helpers.hs +++ /dev/null @@ -1,849 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE BangPatterns #-} -module Lamdera.Wire2.Helpers where - -import System.IO.Unsafe (unsafePerformIO) -import qualified Data.Map as Map -import Data.Map ((!?)) -import qualified Data.List as List -import qualified Data.Graph as Graph - -import Elm.Package -import qualified AST.Source as Src -import qualified Elm.Interface as I -import qualified Elm.ModuleName as Module -import qualified Elm.Package as Pkg -import qualified AST.Canonical as Can -import AST.Canonical -import qualified Data.Name -import qualified Data.Utf8 as Utf8 -import qualified Reporting.Annotation as A -import qualified Reporting.Error as E -import qualified Reporting.Doc as D -import qualified Data.Text as T -import qualified Data.Index as Index -import qualified Elm.String as ES - -import Lamdera -import StandaloneInstances -import qualified CanSer.CanSer as ToSource - - -shouldHaveCodecsGenerated :: Elm.Package.Name -> Bool -shouldHaveCodecsGenerated name = - case name of - -- Some elm packages are ignored because of cyclic dependencies. - -- Those codecs have to be manually defined in `lamdera/codecs`. - -- All other packages, even if their types are defined in js, have codecs generated for their types. - -- Then we manually override specific types in `Lamdera.Wire.[En|De]coder`. - - -- Elm deps used by lamdera/codecs - Name "elm" "bytes" -> False - Name "elm" "core" -> False - - -- Avoid cyclic imports; generated codecs rely on lamdera/codecs:Lamdera.Wire. This is our codec bootstrap module. - Name "lamdera" "codecs" -> False - - -- Everything else should have codecs generated - _ -> True - - -getForeignSig tipe moduleName generatedName ifaces = - -- debugHaskell (T.pack $ "❎❎❎❎❎ ALIAS ENCODER foreignTypeSig for " ++ (Data.Name.toChars generatedName)) $ - case foreignTypeSig moduleName generatedName ifaces of - Just (Forall freeVars tipe_) -> - let - extractedFreevars = extractTvarsInType tipe_ & fmap (\t -> (t, ())) & Map.fromList - in - Forall (Map.union freeVars extractedFreevars) tipe_ - Nothing -> - -- If a foreign type gen function cannot be find, it must be banned! - -- So add type-sig for failure encoder or decoder as appropriate. - if T.isPrefixOf "w2_encode_" (T.pack $ Data.Name.toChars generatedName) - then - (Forall - (Map.fromList [("a", ())]) - (TLambda (TVar "a") tLamdera_Wire2__Encoder)) - - else if T.isPrefixOf "w2_decode_" (T.pack $ Data.Name.toChars generatedName) - then - (Forall - (Map.fromList [("a", ())]) - (TAlias - mLamdera_Wire2 - "Decoder" - [("a", TVar "a")] - (Filled (TType (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" [TVar "a"])))) - else - error $ "impossible getForeignSig on non-wire function: " ++ Data.Name.toChars generatedName - - - -{- NOTE: Any recursive usage of these types in user-code will get caught in the TypeHash first, -the mapping there has been checked extensively against types in packages that are backed by Kernel. - -But we still need to know about them in order to create the right wire encoder/decoder injections --} -isUnsupportedKernelType tipe = - case tipe of - - -- Unconstructable - TType (Module.Canonical (Name "elm" "core") "Basics") "Never" _ -> True - - -- Types backed by JS values - TType (Module.Canonical (Name "elm" "core") "Task") "Task" _ -> True - TType (Module.Canonical (Name "elm" "core") "Process") "Id" _ -> True -- alias of Platform.ProcessId - TType (Module.Canonical (Name "elm" "core") "Platform") "ProcessId" _ -> True - TType (Module.Canonical (Name "elm" "core") "Platform") "Program" _ -> True - TType (Module.Canonical (Name "elm" "core") "Platform") "Router" _ -> True - TType (Module.Canonical (Name "elm" "core") "Platform") "Task" _ -> True - TType (Module.Canonical (Name "elm" "core") "Platform.Cmd") "Cmd" _ -> True - TType (Module.Canonical (Name "elm" "core") "Platform.Sub") "Sub" _ -> True - - TType (Module.Canonical (Name "elm" "bytes") "Bytes.Encode") "Encoder" _ -> True - TType (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" _ -> True - - TType (Module.Canonical (Name "elm" "virtualdom") "VirtualDom") "Node" _ -> True - TType (Module.Canonical (Name "elm" "virtualdom") "VirtualDom") "Attribute" _ -> True - TType (Module.Canonical (Name "elm" "virtualdom") "VirtualDom") "Handler" _ -> True - - TType (Module.Canonical (Name "elm" "json") "Json.Encode") "Value" _ -> True -- js type - TType (Module.Canonical (Name "elm" "json") "Json.Decode") "Decoder" _ -> True -- js type - TType (Module.Canonical (Name "elm" "json") "Json.Decode") "Value" _ -> True -- js type - - - -- JS types we are supporting through JS ref encodings. These serialisations - -- CANNOT BE DECODED OUTSIDE OF THE JS SCOPE THEY WERE ENCODED IN! - TType (Module.Canonical (Name "elm" "file") "File") "File" _ -> False - - - TAlias moduleName typeName tvars (Holey tipe) -> isUnsupportedKernelType tipe - TAlias moduleName typeName tvars (Filled tipe) -> isUnsupportedKernelType tipe - - -- Disable for now, but need to revisit these and whether we want actual proper wire support - -- , (("elm/browser", "Browser.Navigation") "Key" _ -> True -- This is a JS backed value - - _ -> False - - - --- instance Show (Can.Decls) where --- show decls_ = show $ declsToList decls_ - - -declsToList :: Decls -> [Def] -declsToList d = - case d of - Declare def decls -> - def : (declsToList decls) - - DeclareRec def defs decls -> - (def : defs) ++ declsToList decls - - SaveTheEnvironment -> - [] - - -{- For debugging -} -declsToSummary :: Decls -> [(String, Data.Name.Name)] -declsToSummary d = - case d of - Declare def decls -> - ("Declare", defName def) : (declsToSummary decls) - - DeclareRec def defs decls -> - let defs_ = fmap (\d -> ("-> DeclareRecSub", defName d)) defs - in - (("DeclareRec", defName def) : defs_) ++ declsToSummary decls - - SaveTheEnvironment -> - [] - -addDef :: Def -> Decls -> Decls -addDef def_ decls_ = - case decls_ of - Declare def decls -> - Declare def_ (Declare def decls) - - DeclareRec def defs decls -> - Declare def_ (DeclareRec def defs decls) - - SaveTheEnvironment -> - Declare def_ SaveTheEnvironment - - -addRecDef :: [Def] -> Decls -> Decls -addRecDef list decls_ = - case list of - (def_:defs_) -> - case decls_ of - Declare def decls -> - DeclareRec def_ defs_ (Declare def decls) - - DeclareRec def defs decls -> - DeclareRec def_ defs_ (DeclareRec def defs decls) - - SaveTheEnvironment -> - DeclareRec def_ defs_ SaveTheEnvironment - _ -> error $ "addRecDef: impossible list: " ++ show list - - -removeDef :: Def -> Decls -> Decls -removeDef def_ decls_ = - case decls_ of - Declare def decls -> - if (sameName def def_) then - decls - else - Declare def (removeDef def_ decls) - - DeclareRec def defs decls -> - if (sameName def def_) then - decls - else - DeclareRec def (List.deleteBy sameName def_ defs) (removeDef def_ decls) - - SaveTheEnvironment -> - SaveTheEnvironment - - -sameName :: Def -> Def -> Bool -sameName d1 d2 = - defName d1 == defName d2 - -findDef :: Data.Name.Name -> Decls -> Maybe Def -findDef name decls = - decls - & declsToList - & List.find (defNameIs name) - -defNameIs :: Data.Name.Name -> Def -> Bool -defNameIs name def = - name == defName def - -defName :: Def -> Data.Name.Name -defName def = - case def of - Def (A.At region name_) _ _ -> - name_ - TypedDef (A.At region name_) _ _ _ _ -> - name_ - - -foreignTypeTvars :: Module.Raw -> Data.Name.Name -> Map.Map Module.Raw I.Interface -> [Data.Name.Name] -foreignTypeTvars module_ typeName ifaces = - case ifaces & Map.lookup module_ of - Just iface -> - case I._unions iface !? typeName of - Just union -> unionTvars union - Nothing -> - case I._aliases iface !? typeName of - Just alias -> aliasTvars alias - Nothing -> [] - - Nothing -> - [] - - -foreignTypeSig :: Module.Canonical -> Data.Name.Name -> Map.Map Module.Raw I.Interface -> Maybe Can.Annotation -foreignTypeSig (Module.Canonical pkg (moduleRaw)) defName ifaces = - case ifaces & Map.lookup moduleRaw of - Just iface -> - I._values iface !? defName - - Nothing -> - Nothing - - -unionTvars union = - case union of - I.OpenUnion union_ -> _u_vars union_ - I.ClosedUnion union_ -> _u_vars union_ - I.PrivateUnion union_ -> _u_vars union_ - - -aliasTvars alias = - case alias of - I.PublicAlias (Alias tvars tipe) -> tvars - I.PrivateAlias (Alias tvars tipe) -> tvars - - -{- Equivalent of writing `functionName = Debug.todo "functionName"` in Elm -} -namedTodo :: Src.Module -> Data.Name.Name -> Def -namedTodo modul functionName = - let functionName_ = Utf8.fromChars . Data.Name.toChars $ functionName - moduleName = Src.getName modul - in - Def - (a (functionName)) - [] - (a (Call - (a (VarDebug - (Module.Canonical (Name "author" "project") moduleName) - "todo" - (Forall (Map.fromList [("a", ())]) (TLambda (TType (Module.Canonical (Name "elm" "core") "String") "String" []) (TVar "a"))))) - [(a (Str functionName_))])) - - -a v = - A.at (A.Position 0 0) (A.Position 0 10) v - - -encodeSequenceWithoutLength list = - (a (Call (a (VarForeign mLamdera_Wire2 "encodeSequenceWithoutLength" - (Forall - Map.empty - (TLambda - (TType - (Module.Canonical (Name "elm" "core") "List") - "List" - [ tLamdera_Wire2__Encoder - ]) - tLamdera_Wire2__Encoder)))) - [list])) - - -encodeUnsignedInt8 value = - (a (Call (a (VarForeign mLamdera_Wire2 "encodeUnsignedInt8" - (Forall - Map.empty - (TLambda - (TType (Module.Canonical (Name "elm" "core") "Basics") "Int" []) - tLamdera_Wire2__Encoder)))) - [value])) - - -decodeUnsignedInt8 = - (a (VarForeign mLamdera_Wire2 "decodeUnsignedInt8" - (Forall - Map.empty - (TAlias - mLamdera_Wire2 - "Decoder" - [("a", TType (Module.Canonical (Name "elm" "core") "Basics") "Int" [])] - (Filled - (TType - (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") - "Decoder" - [TType (Module.Canonical (Name "elm" "core") "Basics") "Int" []])))))) - - - - -decodeTime = - (a (Binop - "|>" - (Module.Canonical (Name "elm" "core") "Basics") - "apR" - (Forall - (Map.fromList [("a", ()), ("b", ())]) - (TLambda (TVar "a") (TLambda (TLambda (TVar "a") (TVar "b")) (TVar "b")))) - (a (VarForeign - mLamdera_Wire2 - "decodeInt" - (Forall - (Map.fromList []) - (TAlias - mLamdera_Wire2 - "Decoder" - [("a", TType (Module.Canonical (Name "elm" "core") "Basics") "Int" [])] - (Filled - (TType - (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") - "Decoder" - [TType (Module.Canonical (Name "elm" "core") "Basics") "Int" []])))))) - (andThenDecode1 - (a (Lambda - [(a (PVar "t"))] - (a (Call - (a (VarForeign - mLamdera_Wire2 - "succeedDecode" - (Forall - (Map.fromList [("a", ())]) - (TLambda - (TVar "a") - (TAlias - mLamdera_Wire2 - "Decoder" - [("a", TVar "a")] - (Filled - (TType - (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") - "Decoder" - [TVar "a"]))))))) - [ (a (Call - (a (VarForeign - (Module.Canonical (Name "elm" "time") "Time") - "millisToPosix" - (Forall - (Map.fromList []) - (TLambda - (TType - (Module.Canonical (Name "elm" "core") "Basics") - "Int" - []) - (TType - (Module.Canonical (Name "elm" "time") "Time") - "Posix" - []))))) - [(a (VarLocal "t"))])) - ])))) - ))) - - - -andThenDecode1 lambda = - (a (Call (a (VarForeign mLamdera_Wire2 "andThenDecode" - (Forall - (Map.fromList [("a", ()), ("b", ())]) - (TLambda - (TLambda - (TVar "a") - (TAlias - mLamdera_Wire2 - "Decoder" - [("a", TVar "b")] - (Filled (TType (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" [TVar "b"])))) - (TLambda - (TAlias - mLamdera_Wire2 - "Decoder" - [("a", TVar "a")] - (Filled (TType (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" [TVar "a"]))) - (TAlias - mLamdera_Wire2 - "Decoder" - [("a", TVar "b")] - (Filled (TType (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" [TVar "b"])))))))) - [ lambda - ])) - - -andMapDecode1 value = - (a (Call - (a (VarForeign - mLamdera_Wire2 - "andMapDecode" - (Forall - (Map.fromList [("a", ()), ("b", ())]) - (TLambda - (TAlias - mLamdera_Wire2 - "Decoder" - [("a", TVar "a")] - (Filled - (TType (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" [TVar "a"]))) - (TLambda - (TAlias - mLamdera_Wire2 - "Decoder" - [("a", TLambda (TVar "a") (TVar "b"))] - (Filled - (TType - (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") - "Decoder" - [TLambda (TVar "a") (TVar "b")]))) - (TAlias - mLamdera_Wire2 - "Decoder" - [("a", TVar "b")] - (Filled - (TType - (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") - "Decoder" - [TVar "b"])))))))) - [ value - ])) - -succeedDecode value = - (a (Call (a (VarForeign mLamdera_Wire2 "succeedDecode" - (Forall - (Map.fromList [("a", ())]) - (TLambda - (TVar "a") - (TAlias - mLamdera_Wire2 - "Decoder" - [("a", TVar "a")] - (Filled (TType (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" [TVar "a"]))))))) - [ value - ])) - - -failDecode identifier = - -- debugDecoder (Utf8.fromChars $ "failDecode:" ++ identifier) $ - (a (VarForeign mLamdera_Wire2 "failDecode" - (Forall - (Map.fromList [("a", ())]) - (TAlias - mLamdera_Wire2 - "Decoder" - [("a", TVar "a")] - (Filled (TType (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" [TVar "a"])))))) - - -failEncode = - (a (VarForeign - mLamdera_Wire2 - "failEncode" - (Forall - (Map.fromList [("a", ())]) - (TLambda (TVar "a") tLamdera_Wire2__Encoder)))) - - -int value = - a (Int value) - -str value = - a (Str value) - -list values = - a (List values) - -lambda1 pattern expr = - a (Lambda [ pattern ] expr) - -caseof pattern branches = - a (Case pattern branches) - - -(|>) expr1 expr2 = - (a (Binop - "|>" - (Module.Canonical (Name "elm" "core") "Basics") - "apR" - (Forall (Map.fromList [("a", ()), ("b", ())]) (TLambda (TVar "a") (TLambda (TLambda (TVar "a") (TVar "b")) (TVar "b")))) - expr1 - expr2 - ) - ) - -infixr 0 |> - -lvar n = - a (VarLocal n) - - --- Patterns - -pint i = - a (PInt i) - -pvar n = - a (PVar n) - -pAny_ = - a (PAnything) - -call fn args = - (a (Call fn args)) - - -tLamdera_Wire2__Encoder = - (TAlias - mLamdera_Wire2 - "Encoder" - [] - (Filled (TType (Module.Canonical (Name "elm" "bytes") "Bytes.Encode") "Encoder" []))) - - -mLamdera_Wire2 = - (Module.Canonical (Name "lamdera" "codecs") "Lamdera.Wire2") - - -foldlPairs fn list = - case list of - [] -> error "Error: foldlPairs called with no items! Please report this with your code." - x:[] -> x - x:xs -> - foldl (\acc item -> fn acc item ) x xs - -foldrPairs fn list = - case list of - [] -> error "Error: foldrPairs called with no items! Please report this with your code." - x:[] -> x - x:xs -> - fn x (foldrPairs fn xs) - -unwrapAliasesDeep :: Type -> Type -unwrapAliasesDeep t = - case t of - TLambda t1 t2 -> TLambda (unwrapAliasesDeep t1) (unwrapAliasesDeep t2) - - TVar name -> t - - TType (Module.Canonical (Name "elm" "core") "Maybe") "Maybe" [a] -> TType (Module.Canonical (Name "elm" "core") "Maybe") "Maybe" [unwrapAliasesDeep a] - TType (Module.Canonical (Name "elm" "core") "List") "List" [a] -> TType (Module.Canonical (Name "elm" "core") "List") "List" [unwrapAliasesDeep a] - TType (Module.Canonical (Name "elm" "core") "Set") "Set" [a] -> TType (Module.Canonical (Name "elm" "core") "Set") "Set" [unwrapAliasesDeep a] - TType (Module.Canonical (Name "elm" "core") "Array") "Array" [a] -> TType (Module.Canonical (Name "elm" "core") "Array") "Array" [unwrapAliasesDeep a] - - TType (Module.Canonical (Name "elm" "core") "Result") "Result" [err, a] -> - TType (Module.Canonical (Name "elm" "core") "Result") "Result" [unwrapAliasesDeep err, unwrapAliasesDeep a] - - TType (Module.Canonical (Name "elm" "core") "Dict") "Dict" [key, val] -> - TType (Module.Canonical (Name "elm" "core") "Dict") "Dict" [unwrapAliasesDeep key, unwrapAliasesDeep val] - - TType moduleName typeName params -> - -- t -- @TODO wrong to not de-alias params? - TType moduleName typeName (fmap unwrapAliasesDeep params) - - TRecord fieldMap maybeName -> - fieldMap - & fmap (\(FieldType index tipe) -> - FieldType index (unwrapAliasesDeep tipe) - ) - -- @EXTENSIBLERECORDS For now we don't support extensible records, so drop the maybeExtensible - & (\newFieldMap -> TRecord newFieldMap Nothing ) - - TUnit -> t - - TTuple a b Nothing -> TTuple (unwrapAliasesDeep a) (unwrapAliasesDeep b) Nothing - TTuple a b (Just c) -> TTuple (unwrapAliasesDeep a) (unwrapAliasesDeep b) (Just $ unwrapAliasesDeep c) - - TAlias moduleName typeName tvars (Holey tipe) -> unwrapAliasesDeep tipe - TAlias moduleName typeName tvars (Filled tipe) -> unwrapAliasesDeep tipe - - -resolveTvar :: [(Data.Name.Name, Type)] -> Type -> Type -resolveTvar tvarMap t = - case t of - TLambda t1 t2 -> TLambda (resolveTvar tvarMap t1) (resolveTvar tvarMap t2) - - TVar a -> - case List.find (\(t,ti) -> t == a) tvarMap of - Just (tvarName,tvarType) -> - - case extractTvarsInTvars [(tvarName,tvarType)] of - [] -> tvarType - _ -> - {- The var we looked up itself has tvars. This means this particular function we're dealing with - is used in a generic sense relative to other tvars higher up. In our current context, being - 'resolving tvars in type signatures for VarForeign calls', we thus have no need to specialise. - See the Wire_Tvar_Ambiguous.elm test for the example, in particular: - - CustomTypeDefinition (Test.Wire_Tvar_Ambiguous2.AccessControlled (Maybe a)) - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - - Notice the underlined alias takes a type param of `a` – but the given param here itself is `Maybe a`, - so the type signature we want to inject for the Test.Wire_Tvar_Ambiguous2.AccessControlled decoder - should just be `Decoder (AccessControlled a)` - not `Decoder (AccessControlled (Maybe a))`. - - TLDR: no need to specialise this one, leave it generic! -} - TVar a - - -- case ti of - -- -- If we looked up the Tvar and got another Tvar, we've got a tvar - -- -- that's not specific higher up, so leave it as a tvar, but with - -- -- the generalised name that's come down. - -- TVar b -> TVar b - -- _ -> ti - Nothing -> TVar a - - TType modul typename tvars -> - tvars - & fmap (resolveTvar tvarMap) - & TType modul typename - - TRecord fieldMap maybeExtensible -> - case maybeExtensible of - Nothing -> - fieldMap - & fmap (\(FieldType index tipe) -> - FieldType index (resolveTvar tvarMap tipe) - ) - -- @EXTENSIBLERECORDS For now we don't support extensible records, so drop the maybeExtensible - & (\newFieldMap -> TRecord newFieldMap Nothing ) - Just extensibleName -> - case resolveTvar tvarMap (TVar extensibleName) of - TRecord fieldMapExtensible _ -> - fieldMap - & Map.union fieldMapExtensible - & fmap (\(FieldType index tipe) -> - FieldType index (resolveTvar tvarMap tipe) - ) - -- @EXTENSIBLERECORDS For now we don't support extensible records, so drop the maybeExtensible - & (\newFieldMap -> TRecord newFieldMap Nothing ) - - rt -> error $ "resolveTvars: impossible extensible record with non-record type: " ++ show maybeExtensible ++ "\n\n" ++ show rt - - - TUnit -> t - - TTuple a b Nothing -> TTuple (resolveTvar tvarMap a) (resolveTvar tvarMap b) Nothing - TTuple a b (Just c) -> TTuple (resolveTvar tvarMap a) (resolveTvar tvarMap b) (Just $ resolveTvar tvarMap c) - - TAlias moduleName typeName tvars (Holey tipe) -> - let newResolvedTvars = tvars & fmap (\(n, t) -> (n, resolveTvar tvarMap t)) - in TAlias moduleName typeName newResolvedTvars (Filled $ resolveTvar newResolvedTvars tipe) - - TAlias moduleName typeName tvars (Filled tipe) -> - let newResolvedTvars = tvars & fmap (\(n, t) -> (n, resolveTvar tvarMap t)) - in TAlias moduleName typeName newResolvedTvars (Filled $ resolveTvar newResolvedTvars tipe) - - -resolveTvarRenames tvars tvarNames = - tvarNames - & fmap (\tvarName -> - case List.find (\(tvarName_,tvarType) -> tvarName_ == tvarName) tvars of - Just (_,tvarType) -> - case tvarType of - -- If we looked up the Tvar and got another Tvar, we've got a tvar - -- that's not specific higher up, but has been renamed by the parent - -- context, so we rename our ForAll clause and thus all the params - -- that reference back to it - TVar newName -> newName - _ -> tvarName - Nothing -> tvarName - ) - - -extractTvarsInTvars tvars = - tvars - & concatMap (\(tvarName,tvarType) -> - extractTvarsInType tvarType - ) - -extractTvarsInType t = - case t of - TLambda t1 t2 -> [t1,t2] & concatMap extractTvarsInType - TVar a -> [a] - TType modul typename tvars -> tvars & concatMap extractTvarsInType - - TRecord fieldMap maybeExtensible -> - fieldMap - & concatMap (\(FieldType index tipe) -> - extractTvarsInType tipe - ) - - TUnit -> [] - - TTuple a b Nothing -> [a,b] & concatMap extractTvarsInType - TTuple a b (Just c) -> [a,b,c] & concatMap extractTvarsInType - - TAlias moduleName typeName tvars (Holey tipe) -> extractTvarsInType tipe ++ extractTvarsInTvars tvars - TAlias moduleName typeName tvars (Filled tipe) -> extractTvarsInType tipe ++ extractTvarsInTvars tvars - - - -{- - -Equivalent of making - -x = 1 - -into - -x = - let _ = Debug.log "identifier" () - in - 1 - -Helpful for tracing evaluation of function calls as a rudimentary decoder debugger! - --} --- addLetLog cname identifier functionBody = --- (a (Let --- (Def --- (a ("_")) --- [] --- (a (Call --- (a (VarDebug --- cname --- "log" --- (Forall --- (Map.fromList [("a", ())]) --- (TLambda (TType (Module.Canonical (Name "elm" "core") "String") "String" []) (TLambda (TVar "a") (TVar "a")))))) --- [(a (Str $ identifier)), (a (Unit))]))) --- --- functionBody --- )) - -addLetLog :: ES.String -> Expr -> Expr -addLetLog identifier functionBody = - (a (Let - (Def - (a ("_")) - [] - (a (Call - (a (VarForeign (Module.Canonical (Name "lamdera" "codecs") "Lamdera.Wire2") "debug" - (Forall - (Map.fromList [("a", ())]) - (TLambda (TType (Module.Canonical (Name "elm" "core") "String") "String" []) (TVar "a"))) - )) - - [(a (Str $ identifier))] - ) - )) - functionBody - )) - - -debugEncoder :: ES.String -> Expr -> Expr -debugEncoder identifier encoder = - -- encoder - (a (Call - (a (VarForeign (Module.Canonical (Name "elm" "bytes") "Bytes.Encode") "debugEncoder" - (Forall - (Map.fromList [("a", ())]) - (TLambda - (TType (Module.Canonical (Name "elm" "core") "String") "String" []) - (TLambda - (TLambda (TVar "a") (TType (Module.Canonical (Name "elm" "bytes") "Bytes.Encode") "Encoder" [])) - (TLambda (TVar "a") (TType (Module.Canonical (Name "elm" "bytes") "Bytes.Encode") "Encoder" [])))) - ))) - [(a (Str $ identifier)), encoder] - ) - ) - - -debugEncoder_ :: ES.String -> Expr -> Expr -debugEncoder_ identifier encoder = - (a (Call - (a (VarForeign (Module.Canonical (Name "elm" "bytes") "Bytes.Encode") "debugEncoder_" - (Forall - (Map.empty) - (TLambda - (TType (Module.Canonical (Name "elm" "core") "String") "String" []) - (TLambda - (TType (Module.Canonical (Name "elm" "bytes") "Bytes.Encode") "Encoder" []) - (TType (Module.Canonical (Name "elm" "bytes") "Bytes.Encode") "Encoder" []) - )) - ))) - [(a (Str $ identifier)), encoder] - ) - ) - - -debugDecoder :: ES.String -> Expr -> Expr -debugDecoder identifier decoder = - (a (Call (a (VarForeign (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "debugDecoder" - (Forall - (Map.fromList [("a", ())]) - (TLambda - (TType (Module.Canonical (Name "elm" "core") "String") "String" []) - (TLambda - (TType (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" [TVar "a"]) - (TType (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" [TVar "a"]) - ))))) - [(a (Str $ identifier)), decoder] - )) - - -oneOf :: [Expr] -> Expr -oneOf decoders = - (a (Call (a (VarForeign (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "oneOf" - (Forall - (Map.fromList [("a", ())]) - (TLambda - (TType - (Module.Canonical (Name "elm" "core") "List") - "List" - [TType (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" [TVar "a"]]) - (TType (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" [TVar "a"]) - ) - ) - )) - [a $ List decoders] - )) diff --git a/extra/Lamdera/Wire2/Interfaces.hs b/extra/Lamdera/Wire2/Interfaces.hs deleted file mode 100644 index 8aa0f64af..000000000 --- a/extra/Lamdera/Wire2/Interfaces.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Lamdera.Wire2.Interfaces where - -import qualified AST.Source as Src -import AST.Source -import qualified Data.Name -import qualified Reporting.Annotation as A -import Reporting.Annotation -import qualified Data.Utf8 as Utf8 -import qualified Data.Map as Map -import Elm.Package -import qualified Elm.Package as Pkg -import qualified Elm.Interface as I -import qualified Elm.ModuleName as ModuleName - -import Lamdera -import qualified Lamdera.Wire2.Helpers -import StandaloneInstances - -{- Heper functions for AST.Source modifications -} - --- modul = --- data Module = --- Module --- { _name :: Maybe (A.Located Name) --- , _exports :: A.Located Exposing --- , _docs :: Docs --- , _imports :: [Import] --- , _values :: [A.Located Value] --- , _unions :: [A.Located Union] --- , _aliases :: [A.Located Alias] --- , _binops :: [A.Located Infix] --- , _effects :: Effects --- } - --- ifaces = --- map for each module except current one: --- data Interface = --- Interface --- { _home :: Pkg.Name --- , _values :: Map.Map Name.Name Can.Annotation --- , _unions :: Map.Map Name.Name Union --- , _aliases :: Map.Map Name.Name Alias --- , _binops :: Map.Map Name.Name Binop --- } --- deriving (Eq) - -modifyModul :: Name -> Map.Map ModuleName.Raw I.Interface -> Module -> Module -modifyModul pkg ifaces modul = - unsafePerformIO $ do - if (Lamdera.Wire2.Helpers.shouldHaveCodecsGenerated pkg) - then do - -- atomicPutStrLn $ tShow "🧑" $ Src.getName modul - -- atomicPutStrLn $ tShow "πŸ’š" $ Src._exports modul - -- atomicPutStrLn $ tShow "πŸ’™" $ Map.keys ifaces - -- Src._values modul - -- & mapM showValue - - let - newModul = - modul { - Src._values = - (Src._values modul) - -- These stubs are added in so that the functions (which are not yet generated!) - -- can be referenced by user-code that is already in the file. This allows us to - -- write the `expected_w2_[en|de]code_TYPENAME` style tests, which ensures our - -- expected final Elm generation is identical to what would have been ingested - -- had the source actually been literally written in the file as text to begin with! - ++ (unionStubs (Src._unions modul)) - ++ (aliasStubs (Src._aliases modul)) - } - - -- debugPassText "πŸ’™" (hindentFormatValue $ Src._values modul) (pure ()) - -- atomicPutStrLn $ tShow "πŸ’™" $ newModul - -- debugHaskellPass "πŸ’™" newModul (pure newModul) - - -- Note: Env insertion disabled in Wire2, now handled by Wire3 - pure newModul - - else pure modul - - - -hasModeDef :: [Located Union] -> Bool -hasModeDef unions = - unions - & any (\union -> - case union of - A.At _ (Union (A.At _ name) params constructors) -> - name == "Mode" - ) - - -isModeValue :: Located Value -> Bool -isModeValue value = - case value of - A.At _ (Value (A.At _ name) params value typeAnnotation) -> name == "mode" - - -unionStubs :: [Located Union] -> [Located Value] -unionStubs unions = - unions - & concatMap (\(A.At _ (Src.Union (A.At _ name) _ _)) -> - [ _Debug_todo $ Data.Name.fromChars $ "w2_encode_" ++ Data.Name.toChars name - , _Debug_todo $ Data.Name.fromChars $ "w2_decode_" ++ Data.Name.toChars name - ] - ) - - -aliasStubs :: [Located Alias] -> [Located Value] -aliasStubs aliases = - aliases - & concatMap (\(A.At _ (Src.Alias (A.At _ name) _ _)) -> - [ _Debug_todo $ Data.Name.fromChars $ "w2_encode_" ++ Data.Name.toChars name - , _Debug_todo $ Data.Name.fromChars $ "w2_decode_" ++ Data.Name.toChars name - ] - ) - - -a v = - A.at (A.Position 0 0) (A.Position 0 10) v - -showValue (A.At region (Src.Value name pattern expr mtype)) = do - -- data Value = Value (A.Located Name) [Pattern] Expr (Maybe Type) - atomicPutStrLn $ "❀️name: " ++ show name - atomicPutStrLn $ "πŸ’›pattern: " ++ show pattern - atomicPutStrLn $ "πŸ’™expr: " ++ show expr - atomicPutStrLn $ "πŸ’œmtype: " ++ show mtype - -tShow x v = - x ++ show v - -x = - "❀️ πŸ’” β™₯️ πŸ’— πŸ’“ πŸ’• πŸ’– πŸ’› πŸ’™ πŸ’œ πŸ’š" - -_Debug_todo :: Data.Name.Name -> A.Located Src.Value -_Debug_todo functionName = - let functionName_ = Utf8.fromChars . Data.Name.toChars $ functionName - in - a $ Src.Value - (a functionName) - [] - (a (Src.Call (a (Src.VarQual Src.LowVar "Debug" "todo")) [a (Src.Str functionName_)])) - Nothing diff --git a/extra/Wire/Source.hs b/extra/Wire/Source.hs deleted file mode 100644 index 4333186d4..000000000 --- a/extra/Wire/Source.hs +++ /dev/null @@ -1,545 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE BangPatterns #-} - -module Wire.Source (generateCodecs, injectEvergreenExposing, isEvergreenCodecName, evergreenCoreCodecs) where - -{- -Wire.Source is responsible for generating Evergreen codecs for all Elm types. It -does this by injecting generated source code, as this was the fastest and safest -way forward at the time. For some codecs it also writes out type annotations. - -This module is also responsible for figuring out which of these codecs should be -exposed/imported; if the type is reachable, so is the codec. - -Thirdly, we handle the set of built-in codecs here and what code we should -generate in order to interact with them. - -ASSUMPTION: no user code defines any values starting with the string `evg_` - --} - -import qualified AST.Canonical as Can -import Elm.ModuleName (Canonical(..)) -import qualified Elm.ModuleName as ModuleName -import qualified AST.Utils.Type as Type - -import qualified Data.Char -import qualified Data.Map as Map -import qualified Data.List as List -import qualified Data.Text as T -import qualified Data.Name as N -import qualified Elm.Package as Pkg -import qualified Reporting.Annotation as A -import qualified Reporting.Annotation as R -import qualified Data.Utf8 as Utf8 - --- import CanSer.CanSer as CanSer - -import Lamdera -import Wire.PrettyPrint -import StandaloneInstances - - -textToUf8 = - Utf8.fromChars . T.unpack - -insertAfterRegion :: R.Region -> String -> String -> String -insertAfterRegion region@(R.Region _ (R.Position lend cend)) insertion hay = - let - -- !_ = trace (sShow ("insertAfterRegion", region)) () - regionOffset (line, col) [] = length hay - regionOffset (line, col) rest | (line, col+1) >= (lend, cend) = length hay - length rest - regionOffset (line, col) ('\n':xs) = regionOffset (line+1, 0) xs - regionOffset (line, col) (x:xs) = regionOffset (line, col+1) xs - - offset = regionOffset (1, 0) hay - (start, end) = splitAt offset hay - in - start ++ insertion ++ end - - -isEvergreenCodecName :: N.Name -> Bool -isEvergreenCodecName name = "evg_encode_" `T.isPrefixOf` n || "evg_decode_" `T.isPrefixOf` n where n = N.toText name - -injectEvergreenExposing :: Can.Module -> String -> String -injectEvergreenExposing (Can.Module _ _exports _ _ _ _ _ _) s = - -- 1. figure out what types are exposed from `can` - -- 2. inject the encoder/decoders for those types into the exposing statement - -- by finding the first `)\n\n`, and injecting it before that. - -- - we can assume there to be no `exposing (..)` or trailing spaces/comments - -- after the last `)` since elm-format will move/remove those. - -- - - this implementation only assumes there to be no spaces/comments after - -- the last `)`, and that there are two free newlines directly after, - -- which is what elm-format would give us. - let - exposingRegion export = - case export of - Can.ExportEverything r -> r - Can.Export m -> - case Map.elemAt 0 m of -- ASSUMPTION: Export map is non-empty, since - -- parser requires exposing to be non-empty. - (_, A.At r _) -> - -- trace (sShow ("exposingRegion", Map.elemAt 0 m)) - r - - startsWithUppercaseCharacter (x:_) | Data.Char.isUpper x = True - startsWithUppercaseCharacter _ = False - - codecsFor s = ["evg_encode_" ++ s, "evg_decode_" ++ s] - - in - case _exports of - Can.ExportEverything _ -> s - Can.Export mapNameExport -> - insertAfterRegion - (exposingRegion _exports) - (mapNameExport - & Map.keys - & fmap N.toChars - & filter startsWithUppercaseCharacter - & concatMap codecsFor - & leftPadWith ", " - & (\v -> " " ++ v) - ) - s - -leftPadWith _ [] = "" -leftPadWith delim (x:xs) = delim <> x <> leftPadWith delim xs - -generateCodecs :: Map.Map N.Name N.Name -> Can.Module -> T.Text -generateCodecs revImportDict (Can.Module _moduName _docs _exports _decls _unions _aliases _binops _effects) = - let -- massive let-expr so we can closure in _moduName - - !isDebug = False -- unsafePerformIO $ Lamdera.isDebug - - ifDebugT t = "" -- if isDebug then t else "" - - -- HELPERS - -- | qualIfNeeded does a reverse lookup from fully qualified module name to - -- import alias, so we generate valid code when people do e.g. - -- `import Json.Decode as Decode` or when we're actually referencing - -- something in the same module which then shouldn't be fully qualified. - qualIfNeeded :: Canonical -> T.Text - qualIfNeeded moduName | moduName == _moduName = "" - qualIfNeeded moduName@(Canonical _ n) = - case revImportDict Map.!? n of - Just v -> N.toText v <> "." - Nothing -> debug_note (sShow ("Error: qualIfNeeded import not found, please report this.", moduName)) (N.toText n <> ".") - - evergreenCoreEncoder tipes = fmap fst <$> evergreenCoreCodecs qualIfNeeded tipes - evergreenCoreDecoder tipes = fmap snd <$> evergreenCoreCodecs qualIfNeeded tipes - - aliasCodecs :: (N.Name, Can.Alias) -> T.Text - aliasCodecs (name, (Can.Alias names t)) = - let - tName = N.toText name <> leftWrap (N.toText <$> names) - encoder = - --"evg_encode_" <> N.toText name <> " : " <> T.intercalate " -> " (((\v -> "(" <> v <> " -> Lamdera.Wire.Encoder)") <$> N.toText <$> names) ++ [tName, "Lamdera.Wire.Encoder"]) <> "\n" <> - "evg_encode_" <> N.toText name <> leftWrap (codec <$> names) <> " =\n" <> - " " <> encoderForType Map.empty t - decoder = - --"evg_decode_" <> N.toText name <> " : " <> T.intercalate " -> " (((\v -> "(Lamdera.Wire.Decoder " <> v <> ")") <$> N.toText <$> names) ++ ["Lamdera.Wire.Decoder (" <> tName <> ")"]) <> "\n" <> - "evg_decode_" <> N.toText name <> leftWrap (codec <$> names) <> " =\n" - <> (ifDebugT $ - " let _ = Debug.log \"evg_decode_" <> N.toText name <> "\" \"called\"\n" - <> " in\n") - <> " " <> decoderForType Map.empty t - in - encoder <> "\n\n" <> decoder - - unionCodecs :: (N.Name, Can.Union) -> T.Text - unionCodecs (name, (Can.Union _u_vars _u_alts _u_numAlts _u_opts)) = - let - tName = N.toText name <> leftWrap (N.toText <$> _u_vars) - - encoder = - --"evg_encode_" <> N.toText name <> " : " <> T.intercalate " -> " (((\v -> "(" <> v <> " -> Lamdera.Wire.Encoder)") <$> N.toText <$> _u_vars) ++ [tName, "Lamdera.Wire.Encoder"]) <> "\n" <> - "evg_encode_" <> N.toText name <> leftWrap (codec <$> _u_vars) <> " evg_e_thingy =\n" <> - " case evg_e_thingy of\n " - <> T.intercalate "\n " - (case _u_opts of - _ -> encodeUnion _u_vars _u_alts - --Can.Normal -> codecUnion _u_vars _u_alts - --Can.Enum -> error "codec Enum notimpl" - --Can.Unbox -> error "codec Unbox notimpl" - ) - - decoder = - --"evg_decode_" <> N.toText name <> " : " <> T.intercalate " -> " (((\v -> "(Lamdera.Wire.Decoder " <> v <> ")") <$> N.toText <$> _u_vars) ++ ["Lamdera.Wire.Decoder (" <> tName <> ")"]) <> "\n" <> - "evg_decode_" <> N.toText name <> leftWrap (codec <$> _u_vars) <> " =\n" - <> " Lamdera.Wire.decodeString |> Lamdera.Wire.andThenDecode (\\evg_e_thingy ->\n" - <> (ifDebugT $ - " let _ = Debug.log \"evg_decode_" <> N.toText name <> "\" evg_e_thingy\n" - <> " in") - <> " case evg_e_thingy of\n " - <> T.intercalate "\n " - (case _u_opts of - _ -> decodeUnion _u_vars _u_alts - --Can.Normal -> codecUnion _u_vars _u_alts - --Can.Enum -> error "codec Enum notimpl" - --Can.Unbox -> error "codec Unbox notimpl" - ) - -- <> "\n _ -> Lamdera.Wire.failDecode \"" <> N.toText name <> "\"" - <> "\n _ -> Lamdera.Wire.failDecode" - <> "\n )" - - sorted_u_alts = - if (List.length _u_alts > 256) then - -- @TODO put this error somewhere nicer that's not a crash! - error $ "Wow, I ran into a custom type (" <> N.toChars name <> ") with more than 256 values! This is unexpected. Please report this to support." - else - _u_alts - & List.sortOn - -- Ctor N.Name Index.ZeroBased Int [Type] - (\(Can.Ctor name _ _ _) -> N.toChars name) - - in - encoder <> "\n\n" <> decoder - -- @TODO need to move these to a separate v2 generation! - -- newEncoder <> "\n\n" <> newDecoder - - - -- DECODERS - - decodeUnion :: [N.Name] -> [Can.Ctor] -> [T.Text] - decodeUnion _u_vars _u_alts = - (\(Can.Ctor name _ _ tipes) -> - strQuote(N.toText name) <> " -> " <> T.intercalate " |> Lamdera.Wire.andMapDecode " ((decodeSucceed $ N.toText name) : ((\(_, t) -> decoderForType Map.empty t) <$> nargs tipes))) <$> _u_alts - - decoderForType :: Map.Map N.Name Int -> Can.Type -> T.Text - decoderForType varMap t = - case t of - (Can.TVar n) -> codec n - (Can.TUnit) -> unitDec - (Can.TType moduName name tipes) -> - p ((case evergreenCoreDecoder tipes (moduName, name) of - Just c -> c - Nothing -> p $ qualIfNeeded moduName <> "evg_decode_" <> N.toText name - ) <> leftWrap (p <$> decoderForType varMap <$> tipes)) - (Can.TRecord nameFieldTypeMap (Just _)) -> - -- We don't allow sending partial records atm, because we haven't fully figured out how to encode/decode them. - -- "(Lamdera.Wire.failDecode \"partial record\")" - "Lamdera.Wire.failDecode" - (Can.TRecord nameFieldTypeMap Nothing) | Map.null nameFieldTypeMap -> - p (decodeSucceed "{}") - (Can.TRecord nameFieldTypeMap Nothing) -> p $ - let - nameFieldTypes = Can.fieldsToList nameFieldTypeMap - (newVarMap, vars) = manyVars varMap (fst <$> nameFieldTypes) - in - T.intercalate " |> Lamdera.Wire.andMapDecode " $ - p <$> (decodeSucceed "(\\" <> leftWrap vars <> " -> " - <> recLit ((\k -> (N.toText k, getVar newVarMap k)) <$> (fst <$> nameFieldTypes)) <> ")") - : (decoderForType newVarMap <$> (snd <$> nameFieldTypes)) - (Can.TTuple t1 t2 Nothing) -> p $ pairDec (decoderForType varMap t1) (decoderForType varMap t2) - (Can.TTuple t1 t2 (Just t3)) -> p $ tripleDec (decoderForType varMap t1) (decoderForType varMap t2) (decoderForType varMap t3) - (Can.TAlias moduName name nameTypePairs aliasType) -> decoderForType varMap (Can.TType moduName name (snd <$> nameTypePairs)) - -- (Can.TLambda _ _) -> "(Lamdera.Wire.failDecode \"lambda\")" -- <> strQuote (T.pack $ show x) - (Can.TLambda _ _) -> "Lamdera.Wire.failDecode" -- <> strQuote (T.pack $ show x) - - -- D.succeed (\a b c -> { a = a, b = b, c = c }) - -- |> dAndMap decodeInt64 - -- |> dAndMap c_b - -- |> dAndMap decodeUnit - - - -- ENCODERS - - encodeUnion :: [N.Name] -> [Can.Ctor] -> [T.Text] - encodeUnion _u_vars _u_alts = - (\(Can.Ctor name _ _ tipes) -> - N.toText name <> leftWrap (fst <$> nargs tipes) <> " -> " <> sequenceEncWithoutLength ((strEnc (N.toText name)) : ((\(var, t) -> encoderForType Map.empty t <> " " <> var) <$> nargs tipes))) <$> _u_alts - - encoderForType :: Map.Map N.Name Int -> Can.Type -> T.Text - encoderForType varMap t = - case t of - (Can.TVar n) -> codec n - (Can.TUnit) -> unitEnc - (Can.TType moduName name tipes) -> - p ( - (case evergreenCoreEncoder tipes (moduName, name) of - Just c -> c - Nothing -> - qualIfNeeded moduName - <> "evg_encode_" <> N.toText name - ) <> leftWrap (p <$> encoderForType varMap <$> tipes) - ) - (Can.TRecord nameFieldTypeMap (Just _)) -> - -- We don't allow sending partial records atm, because we haven't fully figured out how to encode/decode them. - "Lamdera.Wire.failEncode" - (Can.TRecord nameFieldTypeMap Nothing) -> - let - (newVarMap, recVar) = newRecVar varMap -- store `Map Varname Int` so we can append numbers to varnames to avoid shadowing - in - "(\\" <> recVar <> " -> " - <> sequenceEncWithoutLength ((\(var, t) -> - encoderForType newVarMap t <> " " <> recAccess newVarMap var) <$> Can.fieldsToList nameFieldTypeMap) <> ")" - (Can.TTuple t1 t2 Nothing) -> pairEnc (encoderForType varMap t1) (encoderForType varMap t2) - (Can.TTuple t1 t2 (Just t3)) -> tripleEnc (encoderForType varMap t1) (encoderForType varMap t2) (encoderForType varMap t3) - (Can.TAlias moduName name nameTypePairs aliasType) -> - encoderForType varMap (Can.TType moduName name (snd <$> nameTypePairs)) - -- encoderForType varMap (Type.dealias nameTypePairs aliasType) - (Can.TLambda _ _) -> "Lamdera.Wire.failEncode" -- <> strQuote (T.pack $ show x) - - - in - T.intercalate "\n\n\n" ((unionCodecs <$> Map.toList _unions) <> (aliasCodecs <$> Map.toList _aliases)) - -nargs :: [Can.Type] -> [(T.Text, Can.Type)] -nargs xs = - let - f count t = ("v" <> T.pack (show count), t) - in - imap f xs - -moduleToText (Canonical _ modu) = N.toText modu - -leftWrap [] = "" -leftWrap (x:xs) = " " <> x <> leftWrap xs - -sequenceEnc things = "Lamdera.Wire.encodeSequence [" <> T.intercalate ", " things <> "]" -sequenceEncWithoutLength things = "Lamdera.Wire.encodeSequenceWithoutLength [" <> T.intercalate ", " things <> "]" - -p s = "(" <> s <> ")" - -codec n = "evg_x_c_" <> (N.toText n) - -decodeSucceed s = "Lamdera.Wire.succeedDecode " <> s -strQuote s = T.pack (show (T.unpack s)) -strEnc s = "Lamdera.Wire.encodeString " <> strQuote s -unitEnc = "Lamdera.Wire.encodeUnit" -pairEnc a b = "Lamdera.Wire.encodePair " <> p a <> " " <> p b -tripleEnc a b c = "Lamdera.Wire.encodeTriple " <> p a <> " " <> p b <> " " <> p c -unitDec = "Lamdera.Wire.decodeUnit" -pairDec a b = "Lamdera.Wire.decodePair " <> p a <> " " <> p b -tripleDec a b c = "Lamdera.Wire.decodeTriple " <> p a <> " " <> p b <> " " <> p c -recEnc fields = "{ " <> T.intercalate ", " (N.toText <$> fields) <> " }" -recLit kvpairs = "{ " <> T.intercalate ", " ((\(k, v) -> k <> "=" <> v) <$> kvpairs) <> " }" - -(-->) = (,) - -evergreenCoreCodecs :: (Canonical -> T.Text) -> [Can.Type] -> (Canonical, N.Name) -> Maybe (T.Text, T.Text) -evergreenCoreCodecs qualIfNeeded targs key = - let - -- NOTE: Int argument is the number of type variables of the type in question; FIXME: arity is never used, so do we need to write it down? We know arity from targs context, right? - failCodec n moduName = (typedFailEncode qualIfNeeded targs moduName, typedFailDecode qualIfNeeded targs moduName) - - notimplCodecs = - ((\((pkg, modu, tipe), arity) -> - let - fqType = (Canonical (pkgFromText pkg) modu, tipe) - in (fqType, failCodec arity fqType)) <$> - -- non elm/core types - -- NOTE: none of these packages have been checked exhaustively for types; we should do that - ( [ (("elm/bytes", "Bytes.Encode", "Encoder") --> 0 ) - , (("elm/bytes", "Bytes.Decode", "Decoder") --> 1 ) - -- , (("elm/bytes", "Bytes", "Endianness") --> 0 ) - , (("elm/virtual-dom", "VirtualDom", "Node") --> 1 ) - , (("elm/virtual-dom", "VirtualDom", "Attribute") --> 1 ) - , (("elm/virtual-dom", "VirtualDom", "Handler") --> 1 ) - -- Disable for now, but need to revisit these and whether we want actual proper wire support - -- , (("elm/browser", "Browser", "UrlRequest") --> 0 ) - -- , (("elm/browser", "Browser.Navigation", "Key") --> 0 ) - , (("elm/file", "File", "File") --> 0 ) - -- not implemented yet, but needed by other pkgs - , (("elm/core", "Process", "Id") --> 0 ) -- alias of Platform.ProcessId - , (("elm/core", "Platform", "ProcessId") --> 0 ) -- time - -- not needed by anything immediately, but we don't know how to encode these anyway, so let's fail them now - , (("elm/core", "Platform", "Program") --> 3 ) -- idk - , (("elm/core", "Platform", "Router") --> 2 ) -- idk - , (("elm/core", "Platform", "Task") --> 2 ) -- idk - , (("elm/core", "Platform.Cmd", "Cmd") --> 1 ) -- idk - , (("elm/core", "Platform.Sub", "Sub") --> 1 ) - -- elm/json - , (("elm/json", "Json.Encode", "Value") --> 0 ) -- js type - , (("elm/json", "Json.Decode", "Decoder") --> 1 ) -- js type - , (("elm/json", "Json.Decode", "Value") --> 0 ) -- js type - -- elm/core - , (("elm/core", "Task", "Task") --> 2 ) -- js type - ])) - <> - ( (\((pkg, modu, tipe), res) -> ((Canonical (pkgFromText pkg) modu, tipe), res)) <$> - -- elm/core types; these are exhaustive (but some types are commented out atm) - (\(modu, tipe) -> ("elm/core", modu, tipe) --> ("Lamdera.Wire.encode" <> N.toText tipe, "Lamdera.Wire.decode" <> N.toText tipe)) <$> - [ -- , ("Platform", "ProcessId") - -- , ("Platform", "Program") - -- , ("Platform", "Router") - -- , ("Platform", "Task") - -- , ("Platform.Cmd", "Cmd") - -- , ("Platform.Sub", "Sub") - ] - ) - - - implementedCodecs = - (\((pkg, modu, tipe), res) -> ((Canonical (pkgFromText pkg) modu, tipe), res)) <$> - -- non elm/core types - -- NOTE: none of these packages have been checked exhaustively for types; we should do that - ( [ (("elm/bytes", "Bytes", "Bytes") --> ("Lamdera.Wire.encodeBytes", "Lamdera.Wire.decodeBytes") ) - , (("elm/bytes", "Bytes", "Endianness") --> ("Lamdera.Wire.encodeEndianness", "Lamdera.Wire.decodeEndianness") ) - , (("elm/time", "Time", "Posix") --> ("(\\t -> Lamdera.Wire.encodeInt (Time.posixToMillis t))", "Lamdera.Wire.decodeInt |> Lamdera.Wire.andThenDecode (\\t -> Lamdera.Wire.succeedDecode (Time.millisToPosix t))")) - ] <> - ( - -- elm/core types; these are exhaustive (but some types are commented out atm) - (\(modu, tipe) -> ("elm/core", modu, tipe) --> ("Lamdera.Wire.encode" <> N.toText tipe, "Lamdera.Wire.decode" <> N.toText tipe)) <$> - [ ("Array", "Array") - , ("Basics", "Bool") - , ("Basics", "Float") - , ("Basics", "Int") - , ("Basics", "Never") - , ("Basics", "Order") - , ("Char", "Char") - , ("Dict", "Dict") - , ("List", "List") -- list type is only defined in kernel code, there's no `type List a = List` or similar in elm land. Accidentally maybe? - , ("Maybe", "Maybe") - -- , ("Platform", "ProcessId") - -- , ("Platform", "Program") - -- , ("Platform", "Router") - -- , ("Platform", "Task") - -- , ("Platform.Cmd", "Cmd") - -- , ("Platform.Sub", "Sub") - , ("Result", "Result") - , ("Set", "Set") - , ("String", "String") - ] - ) - ) - - - in - -- NOTE: the injected failEncode and failDecode values follow a simple pattern; they take the (de/en)coders - -- of type variables as arguments; one argument per type variable, in the same order as the type variables - -- in the main type. A two-argument type that we want to `fail` must thus be wrapped in a two-argument lambda - -- that drops both its arguments, for the generated source code to kind-check. Se examples below. - Map.lookup key $ - Map.fromListWithKey (\k a b -> error (sShow ("Wire.Source.evergreenCoreCodecs got duplicate values for a key", k, "namely", a, b))) $ (notimplCodecs ++ implementedCodecs) - -pkgFromText :: T.Text -> Pkg.Name -pkgFromText s = - case T.splitOn "/" s of - [p,m] -> Pkg.Name (textToUf8 p) (textToUf8 m) - _ -> error ("fromText" <> T.unpack s) - - --- Record helpers - -recNameVar varMap = "evg_rec_var" <> T.pack (show (varMap Map.! "evg_rec_var")) -recAccess varMap var = recNameVar varMap <> "." <> N.toText var - --- TODO: manually passing maps around is very verbose and error prone; make a monad wrapping variables and the text output instead - -manyVars :: Map.Map N.Name Int -> [N.Name] -> (Map.Map N.Name Int, [T.Text]) -manyVars varMap vars = - let - fn varMap vars doneVars = - case vars of - [] -> - (varMap, reverse doneVars) - (v:rest) -> - let - (newVarMap, vx) = newGenVar v varMap - in - fn newVarMap rest (vx:doneVars) - in fn varMap vars [] - -newRecVar :: Map.Map N.Name Int -> (Map.Map N.Name Int, T.Text) -newRecVar = - newGenVar "evg_rec_var" - -getVar :: Map.Map N.Name Int -> N.Name -> T.Text -getVar varMap varName = - (N.toText varName) <> T.pack (show (varMap Map.! varName)) - -newGenVar :: N.Name -> Map.Map N.Name Int -> (Map.Map N.Name Int, T.Text) -newGenVar varName varMap = - let - (newVarMap, var) = - case varMap Map.!? varName of - Just count -> (Map.insert varName (1 + count) varMap, N.toText varName <> T.pack (show (count+1))) - Nothing -> (Map.insert varName 0 varMap, N.toText varName <> "0") - in - (newVarMap, var) - -typedFailEncode :: (Canonical -> T.Text) -> [Can.Type] -> (Canonical, N.Name) -> T.Text -typedFailEncode qualIfNeeded targs (can, name) = - -- We wrap the failEncode decoder in a type annotation to say what that targ should be, and then let type inference handle the type annotation for the whole encoder so we don't have to deal with supertypes. - -- In some types, super types aren't written out as super types in the type definition, e.g. the elm/core Dict type is defined as `Dict k v` instead of `Dict comparable v` - let - failEnc 0 = "evg_typed_failure" - failEnc n = p ("\\" <> T.replicate n "_ " <> "-> " <> "evg_typed_failure") - - -- CanSer-style Can.Type pretty-printer that respects aliased/exposed imports. It also never generates newlines. - toElm tipe = - case tipe of - Can.TLambda t1 t2 -> p (toElm t1 <> " -> " <> toElm t2) - Can.TVar name -> N.toText name - Can.TType moduName name [] -> qualIfNeeded moduName <> N.toText name - Can.TType moduName name types | elem moduName [ModuleName.list] -> p (N.toText name <> leftPadWith " " (toElm <$> types)) - Can.TType moduName name types -> p (qualIfNeeded moduName <> N.toText name <> leftPadWith " " (toElm <$> types)) - Can.TRecord nameFieldTypeMap Nothing -> "{ " <> T.intercalate ", " (ftMap nameFieldTypeMap) <> " }" - Can.TRecord nameFieldTypeMap (Just name) -> "{ " <> N.toText name <> " | " <> T.intercalate ", " (ftMap nameFieldTypeMap) <> " }" - Can.TUnit -> "()" - Can.TTuple t1 t2 Nothing -> p (T.intercalate ", " (toElm <$> [t1, t2])) - Can.TTuple t1 t2 (Just t3) -> p (T.intercalate ", " (toElm <$> [t1, t2, t3])) - Can.TAlias moduName name [] _ -> qualIfNeeded moduName <> N.toText name - Can.TAlias moduName name nameTypePairs _ -> p (qualIfNeeded moduName <> N.toText name <> leftPadWith " " (toElm <$> snd <$> nameTypePairs)) - ftMap x = - (\(f, t) -> N.toText f <> " : " <> toElm (fieldType t)) <$> (Map.toList x) - fieldType (Can.FieldType _ t) = t - - in - T.replace "%CanType%" (T.intercalate " " ([qualIfNeeded can <> N.toText name] <> (toElm <$> targs))) $ - T.replace "%Lambda%" (failEnc (length targs)) $ - -- 8 space indentation to be indented more than body of case branches in generated code - "(\n\ - \ let\n\ - \ evg_typed_failure : (%CanType%) -> Lamdera.Wire.Encoder\n\ - \ evg_typed_failure = Lamdera.Wire.failEncode\n\ - \ in %Lambda%\n\ - \ )" - -typedFailDecode :: (Canonical -> T.Text) -> [Can.Type] -> (Canonical, N.Name) -> T.Text -typedFailDecode qualIfNeeded targs (can, name) = - -- since decoders have a type argument in their type, the generated codec has to have the correct type in there or we'll infer it to `a`. - -- We wrap the failDecode decoder in a type annotation to say what that targ should be, and then let type inference handle the type annotation for the whole encoder so we don't have to deal with supertypes. - -- In some types, super types aren't written out as super types in the type definition, e.g. the elm/core Dict type is defined as `Dict k v` instead of `Dict comparable v` - let - failDec 0 = "evg_typed_failure" - failDec n = p ("\\" <> T.replicate n "_ " <> "-> " <> "evg_typed_failure") - - -- CanSer-style Can.Type pretty-printer that respects aliased/exposed imports. It also never generates newlines. - toElm tipe = - case tipe of - Can.TLambda t1 t2 -> p (toElm t1 <> " -> " <> toElm t2) - Can.TVar name -> N.toText name - Can.TType moduName name [] -> qualIfNeeded moduName <> N.toText name - Can.TType moduName name types | elem moduName [ModuleName.list] -> p (N.toText name <> leftPadWith " " (toElm <$> types)) - Can.TType moduName name types -> p (qualIfNeeded moduName <> N.toText name <> leftPadWith " " (toElm <$> types)) - Can.TRecord nameFieldTypeMap Nothing -> "{ " <> T.intercalate ", " (ftMap nameFieldTypeMap) <> " }" - Can.TRecord nameFieldTypeMap (Just name) -> "{ " <> N.toText name <> " | " <> T.intercalate ", " (ftMap nameFieldTypeMap) <> " }" - Can.TUnit -> "()" - Can.TTuple t1 t2 Nothing -> p (T.intercalate ", " (toElm <$> [t1, t2])) - Can.TTuple t1 t2 (Just t3) -> p (T.intercalate ", " (toElm <$> [t1, t2, t3])) - Can.TAlias moduName name [] _ -> qualIfNeeded moduName <> N.toText name - Can.TAlias moduName name nameTypePairs _ -> p (qualIfNeeded moduName <> N.toText name <> leftPadWith " " (toElm <$> snd <$> nameTypePairs)) - ftMap x = - (\(f, t) -> N.toText f <> " : " <> toElm (fieldType t)) <$> (Map.toList x) - fieldType (Can.FieldType _ t) = t - - in - T.replace "%CanType%" (T.intercalate " " ([qualIfNeeded can <> N.toText name] <> (toElm <$> targs))) $ - T.replace "%Lambda%" (failDec (length targs)) $ - T.replace "%Name%" (N.toText name) $ - -- 8 space indentation to be indented more than body of case branches in generated code - -- "(\n\ - -- \ let\n\ - -- \ evg_typed_failure : Lamdera.Wire.Decoder (%CanType%)\n\ - -- \ evg_typed_failure = Lamdera.Wire.failDecode \"%Name%\"\n\ - -- \ in %Lambda%\n\ - -- \ )" - "(\n\ - \ let\n\ - \ evg_typed_failure : Lamdera.Wire.Decoder (%CanType%)\n\ - \ evg_typed_failure = Lamdera.Wire.failDecode\n\ - \ in %Lambda%\n\ - \ )" diff --git a/extra/Wire/Source2.hs b/extra/Wire/Source2.hs deleted file mode 100644 index c8acad7e6..000000000 --- a/extra/Wire/Source2.hs +++ /dev/null @@ -1,574 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE BangPatterns #-} - -module Wire.Source2 (generateCodecs, injectEvergreenExposing, isEvergreenCodecName, evergreenCoreCodecs, addImports) where - -{- -Wire.Source is responsible for generating Evergreen codecs for all Elm types. It -does this by injecting generated source code, as this was the fastest and safest -way forward at the time. For some codecs it also writes out type annotations. - -This module is also responsible for figuring out which of these codecs should be -exposed/imported; if the type is reachable, so is the codec. - -Thirdly, we handle the set of built-in codecs here and what code we should -generate in order to interact with them. - -ASSUMPTION: no user code defines any values starting with the string `w2_` - --} - -import qualified AST.Canonical as Can -import Elm.ModuleName (Canonical(..)) -import qualified Elm.ModuleName as ModuleName -import qualified AST.Utils.Type as Type -import qualified AST.Source as Src -import qualified AST.Source as Valid - -import qualified Data.Char -import qualified Data.Map as Map -import qualified Data.List as List -import qualified Data.Text as T -import qualified Data.Name as N -import qualified Elm.Package as Pkg -import qualified Reporting.Annotation as A -import qualified Reporting.Annotation as R -import qualified Data.Utf8 as Utf8 - --- import CanSer.CanSer as CanSer - -import Lamdera -import Wire.PrettyPrint -import StandaloneInstances - - -textToUf8 = - Utf8.fromChars . T.unpack - - -addImports :: [Src.Import] -> Valid.Module -> Valid.Module -addImports imports module_@(Valid.Module _name _exports _docs _imports _values _unions _aliases _binops _effects) = - module_ { Valid._imports = (imports <> _imports) } - - -isEvergreenCodecName :: N.Name -> Bool -isEvergreenCodecName name = - let - n = N.toText name - in - "evg_encode_" `T.isPrefixOf` n || - "evg_decode_" `T.isPrefixOf` n || - "w2_decode_" `T.isPrefixOf` n || - "w2_encode_" `T.isPrefixOf` n - - -injectEvergreenExposing :: Can.Module -> String -> String -injectEvergreenExposing (Can.Module _ _exports _ _ _ _ _ _) s = - -- 1. figure out what types are exposed from `can` - -- 2. inject the encoder/decoders for those types into the exposing statement - -- by finding the first `)\n\n`, and injecting it before that. - -- - we can assume there to be no `exposing (..)` or trailing spaces/comments - -- after the last `)` since elm-format will move/remove those. - -- - - this implementation only assumes there to be no spaces/comments after - -- the last `)`, and that there are two free newlines directly after, - -- which is what elm-format would give us. - let - exposingRegion export = - case export of - Can.ExportEverything r -> r - Can.Export m -> - case Map.elemAt 0 m of -- ASSUMPTION: Export map is non-empty, since - -- parser requires exposing to be non-empty. - (_, A.At r _) -> - -- trace (sShow ("exposingRegion", Map.elemAt 0 m)) - r - - startsWithUppercaseCharacter (x:_) | Data.Char.isUpper x = True - startsWithUppercaseCharacter _ = False - - -- @TODO remove legacy evg_ exports when deprecated - codecsFor s = ["w2_encode_" ++ s, "w2_decode_" ++ s, "evg_encode_" ++ s, "evg_decode_" ++ s] - - in - case _exports of - Can.ExportEverything _ -> s - Can.Export mapNameExport -> - insertAfterRegion - (exposingRegion _exports) - (mapNameExport - & Map.keys - & fmap N.toChars - & filter startsWithUppercaseCharacter - & concatMap codecsFor - & leftPadWith ", " - & (\v -> " " ++ v) - ) - s - -insertAfterRegion :: R.Region -> String -> String -> String -insertAfterRegion region@(R.Region _ (R.Position lend cend)) insertion hay = - let - -- !_ = trace (sShow ("insertAfterRegion", region)) () - regionOffset (line, col) [] = length hay - regionOffset (line, col) rest | (line, col+1) >= (lend, cend) = length hay - length rest - regionOffset (line, col) ('\n':xs) = regionOffset (line+1, 0) xs - regionOffset (line, col) (x:xs) = regionOffset (line, col+1) xs - - offset = regionOffset (1, 0) hay - (start, end) = splitAt offset hay - in - start ++ insertion ++ end - -leftPadWith _ [] = "" -leftPadWith delim (x:xs) = delim <> x <> leftPadWith delim xs - -generateCodecs :: Map.Map N.Name N.Name -> Can.Module -> T.Text -generateCodecs revImportDict (Can.Module _moduName _docs _exports _decls _unions _aliases _binops _effects) = - let -- massive let-expr so we can closure in _moduName - - !isDebug = False -- unsafePerformIO $ Lamdera.isDebug - - ifDebugT t = "" -- if isDebug then t else "" - - -- HELPERS - -- | qualIfNeeded does a reverse lookup from fully qualified module name to - -- import alias, so we generate valid code when people do e.g. - -- `import Json.Decode as Decode` or when we're actually referencing - -- something in the same module which then shouldn't be fully qualified. - qualIfNeeded :: Canonical -> T.Text - qualIfNeeded moduName | moduName == _moduName = "" - qualIfNeeded moduName@(Canonical _ n) = - case revImportDict Map.!? n of - Just v -> N.toText v <> "." - Nothing -> (N.toText n <> ".") - -- debug_note (sShow ("Error: qualIfNeeded import not found, please report this!", moduName)) (N.toText n <> ".") - - evergreenCoreEncoder tipes = fmap fst <$> evergreenCoreCodecs qualIfNeeded tipes - evergreenCoreDecoder tipes = fmap snd <$> evergreenCoreCodecs qualIfNeeded tipes - - aliasCodecs :: (N.Name, Can.Alias) -> T.Text - aliasCodecs (name, (Can.Alias names t)) = - let - tName = N.toText name <> leftWrap (N.toText <$> names) - encoder = - --"w2_encode_" <> N.toText name <> " : " <> T.intercalate " -> " (((\v -> "(" <> v <> " -> Lamdera.Wire2.Encoder)") <$> N.toText <$> names) ++ [tName, "Lamdera.Wire2.Encoder"]) <> "\n" <> - "expected_w2_encode_" <> N.toText name <> leftWrap (codec <$> names) <> " =\n" <> - " " <> encoderForType Map.empty t - decoder = - --"w2_decode_" <> N.toText name <> " : " <> T.intercalate " -> " (((\v -> "(Lamdera.Wire2.Decoder " <> v <> ")") <$> N.toText <$> names) ++ ["Lamdera.Wire2.Decoder (" <> tName <> ")"]) <> "\n" <> - "expected_w2_decode_" <> N.toText name <> leftWrap (codec <$> names) <> " =\n" - <> (ifDebugT $ - " let _ = Debug.log \"w2_decode_" <> N.toText name <> "\" \"called\"\n" - <> " in\n") - <> " " <> decoderForType Map.empty t - in - encoder <> "\n\n" <> decoder - - unionCodecs :: (N.Name, Can.Union) -> T.Text - unionCodecs (name, (Can.Union _u_vars _u_alts _u_numAlts _u_opts)) = - let - tName = N.toText name <> leftWrap (N.toText <$> _u_vars) - - sorted_u_alts = - if (List.length _u_alts > 256) then - -- @TODO put this error somewhere nicer that's not a crash! - error $ "Error: I ran into a custom type (" <> N.toChars name <> ") with more than 256 values! Please report this!" - else - _u_alts - & List.sortOn - -- Ctor N.Name Index.ZeroBased Int [Type] - (\(Can.Ctor name _ _ _) -> N.toChars name) - - encoder = - "expected_w2_encode_" <> N.toText name <> leftWrap (codec <$> _u_vars) <> " w2v =\n" <> - " case w2v of\n " - <> T.intercalate "\n " - (case _u_opts of - _ -> encodeUnion _u_vars sorted_u_alts - --Can.Normal -> codecUnion _u_vars _u_alts - --Can.Enum -> error "codec Enum notimpl" - --Can.Unbox -> error "codec Unbox notimpl" - ) - - encodeUnion :: [N.Name] -> [Can.Ctor] -> [T.Text] - encodeUnion _u_vars _u_alts = - _u_alts - & imap - (\i (Can.Ctor name _ _ tipes) -> - N.toText name <> leftWrap (fst <$> nargs tipes) <> " -> " <> sequenceEncWithoutLength (("Lamdera.Wire2.encodeUnsignedInt8 " <> (T.pack $ show i)) : ((\(var, t) -> encoderForType Map.empty t <> " " <> var) <$> nargs tipes))) - - decoder = - "expected_w2_decode_" <> N.toText name <> leftWrap (codec <$> _u_vars) <> " =\n" - <> " Lamdera.Wire2.decodeUnsignedInt8 |> Lamdera.Wire2.andThenDecode (\\w2v ->\n" - <> (ifDebugT $ - " let _ = Debug.log \"w2_decode_" <> N.toText name <> "\" w2v\n" - <> " in\n") - <> " case w2v of\n " - <> T.intercalate "\n " (decodeUnion _u_vars sorted_u_alts) - -- <> "\n _ -> Lamdera.Wire2.failDecode \"" <> N.toText name <> "\"" - <> "\n _ -> Lamdera.Wire2.failDecode" - <> "\n )" - - decodeUnion :: [N.Name] -> [Can.Ctor] -> [T.Text] - decodeUnion _u_vars _u_alts = - _u_alts - & imap - (\i (Can.Ctor name _ _ tipes) -> - (T.pack $ show i) <> " -> " <> T.intercalate " |> Lamdera.Wire2.andMapDecode " ((decodeSucceed $ N.toText name) : ((\(_, t) -> decoderForType Map.empty t) <$> nargs tipes))) - - in - encoder <> "\n\n" <> decoder - - - decoderForType :: Map.Map N.Name Int -> Can.Type -> T.Text - decoderForType varMap t = - case t of - (Can.TVar n) -> - codec n - - (Can.TUnit) -> - unitDec - - (Can.TType moduName name tipes) -> - p ((case evergreenCoreDecoder tipes (moduName, name) of - Just c -> c - Nothing -> p $ qualIfNeeded moduName <> "w2_decode_" <> N.toText name - ) <> leftWrap (p <$> decoderForType varMap <$> tipes)) - - (Can.TRecord nameFieldTypeMap (Just _)) -> - -- We don't allow sending partial records atm, because we haven't fully figured out how to encode/decode them. - -- "(Lamdera.Wire2.failDecode \"partial record\")" - "Lamdera.Wire2.failDecode" - -- error "Wire: disallowed partial record encountered. Please report this issue!" - - (Can.TRecord nameFieldTypeMap Nothing) | Map.null nameFieldTypeMap -> - p (decodeSucceed "{}") - - (Can.TRecord nameFieldTypeMap Nothing) -> p $ - let - nameFieldTypes = Can.fieldsToList nameFieldTypeMap - (newVarMap, vars) = manyVars varMap (fst <$> nameFieldTypes) - in - T.intercalate " |> Lamdera.Wire2.andMapDecode " $ - p <$> (decodeSucceed "(\\" <> leftWrap vars <> " -> " - <> recLit ((\k -> (N.toText k, getVar newVarMap k)) <$> (fst <$> nameFieldTypes)) <> ")") - : (decoderForType newVarMap <$> (snd <$> nameFieldTypes)) - - (Can.TTuple t1 t2 Nothing) -> - p $ pairDec (decoderForType varMap t1) (decoderForType varMap t2) - - (Can.TTuple t1 t2 (Just t3)) -> - p $ tripleDec (decoderForType varMap t1) (decoderForType varMap t2) (decoderForType varMap t3) - - (Can.TAlias moduName name nameTypePairs aliasType) -> - decoderForType varMap (Can.TType moduName name (snd <$> nameTypePairs)) - - (Can.TLambda _ _) -> - -- "(Lamdera.Wire2.failDecode \"lambda\")" -- <> strQuote (T.pack $ show x) - "Lamdera.Wire2.failDecode" -- <> strQuote (T.pack $ show x) - -- error "Wire: disallowed function encountered. Please report this issue!" - - - encoderForType :: Map.Map N.Name Int -> Can.Type -> T.Text - encoderForType varMap t = - case t of - (Can.TVar n) -> - codec n - - (Can.TUnit) -> - unitEnc - - (Can.TType moduName name tipes) -> - p ( - (case evergreenCoreEncoder tipes (moduName, name) of - Just c -> c - Nothing -> - qualIfNeeded moduName - <> "w2_encode_" <> N.toText name - ) <> leftWrap (p <$> encoderForType varMap <$> tipes) - ) - - (Can.TRecord nameFieldTypeMap (Just _)) -> - -- We don't allow sending partial records atm, because we haven't fully figured out how to encode/decode them. - "Lamdera.Wire2.failEncode" - -- error "Wire: disallowed partial record encountered. Please report this issue!" - - (Can.TRecord nameFieldTypeMap Nothing) -> - let - (newVarMap, recVar) = newRecVar varMap -- store `Map Varname Int` so we can append numbers to varnames to avoid shadowing - in - "(\\" <> recVar <> " -> " - <> sequenceEncWithoutLength ((\(var, t) -> - encoderForType newVarMap t <> " " <> recAccess newVarMap var) <$> Can.fieldsToList nameFieldTypeMap) <> ")" - - (Can.TTuple t1 t2 Nothing) -> - pairEnc (encoderForType varMap t1) (encoderForType varMap t2) - - (Can.TTuple t1 t2 (Just t3)) -> - tripleEnc (encoderForType varMap t1) (encoderForType varMap t2) (encoderForType varMap t3) - - (Can.TAlias moduName name nameTypePairs aliasType) -> - encoderForType varMap (Can.TType moduName name (snd <$> nameTypePairs)) - -- encoderForType varMap (Type.dealias nameTypePairs aliasType) - - (Can.TLambda _ _) -> - "Lamdera.Wire2.failEncode" -- <> strQuote (T.pack $ show x) - -- error "Wire: disallowed partial record encountered. Please report this issue!" - in - T.intercalate "\n\n\n" ((unionCodecs <$> Map.toList _unions) <> (aliasCodecs <$> Map.toList _aliases)) - - -nargs :: [Can.Type] -> [(T.Text, Can.Type)] -nargs xs = - let - f count t = ("v" <> T.pack (show count), t) - in - imap f xs - - -moduleToText (Canonical _ modu) = N.toText modu - -leftWrap [] = "" -leftWrap (x:xs) = " " <> x <> leftWrap xs - -sequenceEnc things = "Lamdera.Wire2.encodeSequence [" <> T.intercalate ", " things <> "]" -sequenceEncWithoutLength things = "Lamdera.Wire2.encodeSequenceWithoutLength [" <> T.intercalate ", " things <> "]" - -p s = "(" <> s <> ")" - -codec n = "w2_x_c_" <> (N.toText n) - -decodeSucceed s = "Lamdera.Wire2.succeedDecode " <> s -strQuote s = T.pack (show (T.unpack s)) -strEnc s = "Lamdera.Wire2.encodeString " <> strQuote s -unitEnc = "Lamdera.Wire2.encodeUnit" -pairEnc a b = "Lamdera.Wire2.encodePair " <> p a <> " " <> p b -tripleEnc a b c = "Lamdera.Wire2.encodeTriple " <> p a <> " " <> p b <> " " <> p c -unitDec = "Lamdera.Wire2.decodeUnit" -pairDec a b = "Lamdera.Wire2.decodePair " <> p a <> " " <> p b -tripleDec a b c = "Lamdera.Wire2.decodeTriple " <> p a <> " " <> p b <> " " <> p c -recEnc fields = "{ " <> T.intercalate ", " (N.toText <$> fields) <> " }" -recLit kvpairs = "{ " <> T.intercalate ", " ((\(k, v) -> k <> "=" <> v) <$> kvpairs) <> " }" - -(-->) = (,) - -evergreenCoreCodecs :: (Canonical -> T.Text) -> [Can.Type] -> (Canonical, N.Name) -> Maybe (T.Text, T.Text) -evergreenCoreCodecs qualIfNeeded targs key = - let - -- NOTE: Int argument is the number of type variables of the type in question; FIXME: arity is never used, so do we need to write it down? We know arity from targs context, right? - failCodec n moduName = (typedFailEncode qualIfNeeded targs moduName, typedFailDecode qualIfNeeded targs moduName) - - notimplCodecs = - ((\((pkg, modu, tipe), arity) -> - let - fqType = (Canonical (pkgFromText pkg) modu, tipe) - in (fqType, failCodec arity fqType)) <$> - -- non elm/core types - -- NOTE: Most of these should get caught in the TypeDiff. The mapping there has been checked extensively against types in packages that are backed by Kernel. - ( [ (("elm/bytes", "Bytes.Encode", "Encoder") --> 0 ) - , (("elm/bytes", "Bytes.Decode", "Decoder") --> 1 ) - -- , (("elm/bytes", "Bytes", "Endianness") --> 0 ) - , (("elm/virtual-dom", "VirtualDom", "Node") --> 1 ) - , (("elm/virtual-dom", "VirtualDom", "Attribute") --> 1 ) - , (("elm/virtual-dom", "VirtualDom", "Handler") --> 1 ) - -- Disable for now, but need to revisit these and whether we want actual proper wire support - -- , (("elm/browser", "Browser", "UrlRequest") --> 0 ) - -- , (("elm/browser", "Browser.Navigation", "Key") --> 0 ) - , (("elm/file", "File", "File") --> 0 ) - -- not implemented yet, but needed by other pkgs - , (("elm/core", "Process", "Id") --> 0 ) -- alias of Platform.ProcessId - , (("elm/core", "Platform", "ProcessId") --> 0 ) -- time - -- not needed by anything immediately, but we don't know how to encode these anyway, so let's fail them now - , (("elm/core", "Platform", "Program") --> 3 ) -- idk - , (("elm/core", "Platform", "Router") --> 2 ) -- idk - , (("elm/core", "Platform", "Task") --> 2 ) -- idk - , (("elm/core", "Platform.Cmd", "Cmd") --> 1 ) -- idk - , (("elm/core", "Platform.Sub", "Sub") --> 1 ) - -- elm/json - , (("elm/json", "Json.Encode", "Value") --> 0 ) -- js type - , (("elm/json", "Json.Decode", "Decoder") --> 1 ) -- js type - , (("elm/json", "Json.Decode", "Value") --> 0 ) -- js type - -- elm/core - , (("elm/core", "Task", "Task") --> 2 ) -- js type - ])) - <> - ( (\((pkg, modu, tipe), res) -> ((Canonical (pkgFromText pkg) modu, tipe), res)) <$> - -- elm/core types; these are exhaustive (but some types are commented out atm) - (\(modu, tipe) -> ("elm/core", modu, tipe) --> ("Lamdera.Wire2.encode" <> N.toText tipe, "Lamdera.Wire2.decode" <> N.toText tipe)) <$> - [ -- , ("Platform", "ProcessId") - -- , ("Platform", "Program") - -- , ("Platform", "Router") - -- , ("Platform", "Task") - -- , ("Platform.Cmd", "Cmd") - -- , ("Platform.Sub", "Sub") - ] - ) - - - implementedCodecs = - (\((pkg, modu, tipe), res) -> ((Canonical (pkgFromText pkg) modu, tipe), res)) <$> - -- non elm/core types - -- NOTE: Most of these should get caught in the TypeDiff. The mapping there has been checked extensively against types in packages that are backed by Kernel. - ( [ (("elm/bytes", "Bytes", "Bytes") --> ("Lamdera.Wire2.encodeBytes", "Lamdera.Wire2.decodeBytes") ) - , (("elm/bytes", "Bytes", "Endianness") --> ("Lamdera.Wire2.encodeEndianness", "Lamdera.Wire2.decodeEndianness") ) - , (("elm/time", "Time", "Posix") --> ("(\\t -> Lamdera.Wire2.encodeInt (Time.posixToMillis t))", "Lamdera.Wire2.decodeInt |> Lamdera.Wire2.andThenDecode (\\t -> Lamdera.Wire2.succeedDecode (Time.millisToPosix t))")) - ] <> - ( - -- elm/core types; these are exhaustive (but some types are commented out atm) - (\(modu, tipe) -> ("elm/core", modu, tipe) --> ("Lamdera.Wire2.encode" <> N.toText tipe, "Lamdera.Wire2.decode" <> N.toText tipe)) <$> - [ ("Array", "Array") - , ("Basics", "Bool") - , ("Basics", "Float") - , ("Basics", "Int") - , ("Basics", "Never") - , ("Basics", "Order") - , ("Char", "Char") - , ("Dict", "Dict") - , ("List", "List") -- list type is only defined in kernel code, there's no `type List a = List` or similar in elm land. Accidentally maybe? - , ("Maybe", "Maybe") - -- , ("Platform", "ProcessId") - -- , ("Platform", "Program") - -- , ("Platform", "Router") - -- , ("Platform", "Task") - -- , ("Platform.Cmd", "Cmd") - -- , ("Platform.Sub", "Sub") - , ("Result", "Result") - , ("Set", "Set") - , ("String", "String") - ] - ) - ) - in - -- NOTE: the injected failEncode and failDecode values follow a simple pattern; they take the (de/en)coders - -- of type variables as arguments; one argument per type variable, in the same order as the type variables - -- in the main type. A two-argument type that we want to `fail` must thus be wrapped in a two-argument lambda - -- that drops both its arguments, for the generated source code to kind-check. Se examples below. - Map.lookup key $ - Map.fromListWithKey (\k a b -> error (sShow ("Error: got duplicate values for a key", k, "namely", a, b, ". Please report this!"))) $ (notimplCodecs ++ implementedCodecs) - - -pkgFromText :: T.Text -> Pkg.Name -pkgFromText s = - case T.splitOn "/" s of - [p,m] -> Pkg.Name (textToUf8 p) (textToUf8 m) - _ -> error ("Error: ran into a strange package: " <> T.unpack s <> ". Please report this!") - - --- Record helpers - -recNameVar varMap = "w2_rec_var" <> T.pack (show (varMap Map.! "w2_rec_var")) -recAccess varMap var = recNameVar varMap <> "." <> N.toText var - --- TODO: manually passing maps around is very verbose and error prone; make a monad wrapping variables and the text output instead - -manyVars :: Map.Map N.Name Int -> [N.Name] -> (Map.Map N.Name Int, [T.Text]) -manyVars varMap vars = - let - fn varMap vars doneVars = - case vars of - [] -> - (varMap, reverse doneVars) - (v:rest) -> - let - (newVarMap, vx) = newGenVar v varMap - in - fn newVarMap rest (vx:doneVars) - in fn varMap vars [] - -newRecVar :: Map.Map N.Name Int -> (Map.Map N.Name Int, T.Text) -newRecVar = - newGenVar "w2_rec_var" - -getVar :: Map.Map N.Name Int -> N.Name -> T.Text -getVar varMap varName = - (N.toText varName) <> T.pack (show (varMap Map.! varName)) - -newGenVar :: N.Name -> Map.Map N.Name Int -> (Map.Map N.Name Int, T.Text) -newGenVar varName varMap = - let - (newVarMap, var) = - case varMap Map.!? varName of - Just count -> (Map.insert varName (1 + count) varMap, N.toText varName <> T.pack (show (count+1))) - Nothing -> (Map.insert varName 0 varMap, N.toText varName <> "0") - in - (newVarMap, var) - -typedFailEncode :: (Canonical -> T.Text) -> [Can.Type] -> (Canonical, N.Name) -> T.Text -typedFailEncode qualIfNeeded targs (can, name) = - -- We wrap the failEncode decoder in a type annotation to say what that targ should be, and then let type inference handle the type annotation for the whole encoder so we don't have to deal with supertypes. - -- In some types, super types aren't written out as super types in the type definition, e.g. the elm/core Dict type is defined as `Dict k v` instead of `Dict comparable v` - let - failEnc 0 = "w2_typed_failure" - failEnc n = p ("\\" <> T.replicate n "_ " <> "-> " <> "w2_typed_failure") - - -- CanSer-style Can.Type pretty-printer that respects aliased/exposed imports. It also never generates newlines. - toElm tipe = - case tipe of - Can.TLambda t1 t2 -> p (toElm t1 <> " -> " <> toElm t2) - Can.TVar name -> N.toText name - Can.TType moduName name [] -> qualIfNeeded moduName <> N.toText name - Can.TType moduName name types | elem moduName [ModuleName.list] -> p (N.toText name <> leftPadWith " " (toElm <$> types)) - Can.TType moduName name types -> p (qualIfNeeded moduName <> N.toText name <> leftPadWith " " (toElm <$> types)) - Can.TRecord nameFieldTypeMap Nothing -> "{ " <> T.intercalate ", " (ftMap nameFieldTypeMap) <> " }" - Can.TRecord nameFieldTypeMap (Just name) -> "{ " <> N.toText name <> " | " <> T.intercalate ", " (ftMap nameFieldTypeMap) <> " }" - Can.TUnit -> "()" - Can.TTuple t1 t2 Nothing -> p (T.intercalate ", " (toElm <$> [t1, t2])) - Can.TTuple t1 t2 (Just t3) -> p (T.intercalate ", " (toElm <$> [t1, t2, t3])) - Can.TAlias moduName name [] _ -> qualIfNeeded moduName <> N.toText name - Can.TAlias moduName name nameTypePairs _ -> p (qualIfNeeded moduName <> N.toText name <> leftPadWith " " (toElm <$> snd <$> nameTypePairs)) - ftMap x = - (\(f, t) -> N.toText f <> " : " <> toElm (fieldType t)) <$> (Map.toList x) - fieldType (Can.FieldType _ t) = t - - in - T.replace "%CanType%" (T.intercalate " " ([qualIfNeeded can <> N.toText name] <> (toElm <$> targs))) $ - T.replace "%Lambda%" (failEnc (length targs)) $ - -- 8 space indentation to be indented more than body of case branches in generated code - -- "(\n\ - -- \ let\n\ - -- \ w2_typed_failure : (%CanType%) -> Lamdera.Wire2.Encoder\n\ - -- \ w2_typed_failure = Lamdera.Wire2.failEncode\n\ - -- \ in %Lambda%\n\ - -- \ )" - "Lamdera.Wire2.failEncode" - -typedFailDecode :: (Canonical -> T.Text) -> [Can.Type] -> (Canonical, N.Name) -> T.Text -typedFailDecode qualIfNeeded targs (can, name) = - -- since decoders have a type argument in their type, the generated codec has to have the correct type in there or we'll infer it to `a`. - -- We wrap the failDecode decoder in a type annotation to say what that targ should be, and then let type inference handle the type annotation for the whole encoder so we don't have to deal with supertypes. - -- In some types, super types aren't written out as super types in the type definition, e.g. the elm/core Dict type is defined as `Dict k v` instead of `Dict comparable v` - let - failDec 0 = "w2_typed_failure" - failDec n = p ("\\" <> T.replicate n "_ " <> "-> " <> "w2_typed_failure") - - -- CanSer-style Can.Type pretty-printer that respects aliased/exposed imports. It also never generates newlines. - toElm tipe = - case tipe of - Can.TLambda t1 t2 -> p (toElm t1 <> " -> " <> toElm t2) - Can.TVar name -> N.toText name - Can.TType moduName name [] -> qualIfNeeded moduName <> N.toText name - Can.TType moduName name types | elem moduName [ModuleName.list] -> p (N.toText name <> leftPadWith " " (toElm <$> types)) - Can.TType moduName name types -> p (qualIfNeeded moduName <> N.toText name <> leftPadWith " " (toElm <$> types)) - Can.TRecord nameFieldTypeMap Nothing -> "{ " <> T.intercalate ", " (ftMap nameFieldTypeMap) <> " }" - Can.TRecord nameFieldTypeMap (Just name) -> "{ " <> N.toText name <> " | " <> T.intercalate ", " (ftMap nameFieldTypeMap) <> " }" - Can.TUnit -> "()" - Can.TTuple t1 t2 Nothing -> p (T.intercalate ", " (toElm <$> [t1, t2])) - Can.TTuple t1 t2 (Just t3) -> p (T.intercalate ", " (toElm <$> [t1, t2, t3])) - Can.TAlias moduName name [] _ -> qualIfNeeded moduName <> N.toText name - Can.TAlias moduName name nameTypePairs _ -> p (qualIfNeeded moduName <> N.toText name <> leftPadWith " " (toElm <$> snd <$> nameTypePairs)) - ftMap x = - (\(f, t) -> N.toText f <> " : " <> toElm (fieldType t)) <$> (Map.toList x) - fieldType (Can.FieldType _ t) = t - - in - T.replace "%CanType%" (T.intercalate " " ([qualIfNeeded can <> N.toText name] <> (toElm <$> targs))) $ - T.replace "%Lambda%" (failDec (length targs)) $ - T.replace "%Name%" (N.toText name) $ - -- 8 space indentation to be indented more than body of case branches in generated code - -- "(\n\ - -- \ let\n\ - -- \ w2_typed_failure : Lamdera.Wire2.Decoder (%CanType%)\n\ - -- \ w2_typed_failure = Lamdera.Wire2.failDecode \"%Name%\"\n\ - -- \ in %Lambda%\n\ - -- \ )" - "Lamdera.Wire2.failDecode" diff --git a/test/Lamdera/Evergreen/TestMigrationHarness.hs b/test/Lamdera/Evergreen/TestMigrationHarness.hs index dbb25fef9..41aa42768 100644 --- a/test/Lamdera/Evergreen/TestMigrationHarness.hs +++ b/test/Lamdera/Evergreen/TestMigrationHarness.hs @@ -48,7 +48,6 @@ suite = tests expectEqualTextTrimmed (Lamdera.Evergreen.MigrationHarness.historicMigrations migrations nextVersion "BackendModel") [text| 1 -> decodeType 5 2 bytes T2.w3_decode_BackendModel - |> fallback (\_ -> decodeType 5 2 bytes T2.w2_decode_BackendModel) |> upgradeSucceeds |> otherwiseError |] @@ -59,14 +58,12 @@ suite = tests expectEqualTextTrimmed (Lamdera.Evergreen.MigrationHarness.historicMigrations migrations nextVersion "BackendModel") [text| 1 -> decodeType 5 1 bytes T1.w3_decode_BackendModel - |> fallback (\_ -> decodeType 5 1 bytes T1.w2_decode_BackendModel) |> thenMigrateModel 5 M2.backendModel T1.w3_encode_BackendModel T2.w3_decode_BackendModel 2 |> thenMigrateModel 5 (always ModelUnchanged) T2.w3_encode_BackendModel T3.w3_decode_BackendModel 3 |> upgradeSucceeds |> otherwiseError 2 -> decodeType 5 3 bytes T3.w3_decode_BackendModel - |> fallback (\_ -> decodeType 5 3 bytes T3.w2_decode_BackendModel) |> upgradeSucceeds |> otherwiseError |] @@ -91,12 +88,10 @@ suite = tests [text| 60 -> decodeType 5 62 bytes T62.w3_decode_BackendModel - |> fallback (\_ -> decodeType 5 62 bytes T62.w2_decode_BackendModel) |> upgradeSucceeds |> otherwiseError 61 -> decodeType 5 62 bytes T62.w3_decode_BackendModel - |> fallback (\_ -> decodeType 5 62 bytes T62.w2_decode_BackendModel) |> upgradeSucceeds |> otherwiseError |] @@ -121,13 +116,11 @@ suite = tests [text| 60 -> decodeType 5 57 bytes T57.w3_decode_BackendModel - |> fallback (\_ -> decodeType 5 57 bytes T57.w2_decode_BackendModel) |> thenMigrateModel 5 M62.backendModel T57.w3_encode_BackendModel T62.w3_decode_BackendModel 62 |> upgradeSucceeds |> otherwiseError 61 -> decodeType 5 57 bytes T57.w3_decode_BackendModel - |> fallback (\_ -> decodeType 5 57 bytes T57.w2_decode_BackendModel) |> thenMigrateModel 5 M62.backendModel T57.w3_encode_BackendModel T62.w3_decode_BackendModel 62 |> upgradeSucceeds |> otherwiseError @@ -164,7 +157,6 @@ suite = tests case version of 1 -> decodeType 5 version bytes T1.w3_decode_BackendModel - |> fallback (\_ -> decodeType 5 version bytes T1.w2_decode_BackendModel) |> upgradeIsCurrent |> otherwiseError @@ -266,14 +258,12 @@ suite = tests case version of 1 -> decodeType 5 1 bytes T1.w3_decode_BackendModel - |> fallback (\_ -> decodeType 5 1 bytes T1.w2_decode_BackendModel) |> thenMigrateModel 5 M2.backendModel T1.w3_encode_BackendModel T2.w3_decode_BackendModel 2 |> upgradeSucceeds |> otherwiseError 2 -> decodeType 5 version bytes T2.w3_decode_BackendModel - |> fallback (\_ -> decodeType 5 version bytes T2.w2_decode_BackendModel) |> upgradeIsCurrent |> otherwiseError diff --git a/test/Test/Caching.hs b/test/Test/Caching.hs index d3325297f..45b2a1e29 100644 --- a/test/Test/Caching.hs +++ b/test/Test/Caching.hs @@ -58,7 +58,7 @@ suite = tests $ will_fail_on_elm_caches = - Html.w2_encode_Html + Html.w3_encode_Html |] withDebug $ captureProcessOutput $ Lamdera.Compile.makeDev project ["src/Main.elm"]