Handle tvar renames & foreign refs

lamdera · Nov 12, 2023 · 194d701 · 194d701
1 parent b71c7ad
commit 194d701
Show file tree

Hide file tree

Showing 7 changed files with 358 additions and 66 deletions.
diff --git a/extra/Lamdera.hs b/extra/Lamdera.hs
@@ -23,10 +23,10 @@ module Lamdera
   , debugPass
   , debugPassText
   , debugHaskell
+  , debugHaskellWhen
   , debugHaskellPass
   , debugHaskellPassWhen
   , debugHaskellPassDiffWhen
-  , debugHaskellWhen
   -- , PP.sShow
   , T.Text
   , (<>)

diff --git a/extra/Lamdera/Wire3/Core.hs b/extra/Lamdera/Wire3/Core.hs
@@ -394,47 +394,163 @@ decoderUnion isTest_ ifaces pkg modul decls unionName union =
 -- on that tvar name, returning all the constraint field names and types. This can then be used
 -- to construct an anonymous record constraint for the type signature.
 -- See Wire_Record_Extensible4_DB.elm for an example.
-getTvarConstraint :: Data.Name.Name -> Type -> Map.Map Data.Name.Name Type
-getTvarConstraint tvarName tipe =
+getRecordConstraints :: Data.Name.Name -> Type -> Map.Map Data.Name.Name Type
+getRecordConstraints tvarName tipe =
   -- @TODO cover all the possible constraint types!
-  -- debugHaskellPass ("🧡 getTvarConstraint ") tipe $
+  -- debugHaskellPass ("🔵 getRecordConstraints ") (tvarName, tipe) $
   case tipe of
     TType cname aliasName tvars ->
-      tvars & fmap (getTvarConstraint tvarName) & Map.unions
+      tvars & fmap (getRecordConstraints tvarName) & Map.unions
 
     TRecord fields ext ->
       case ext of
         Nothing ->
-          fields & fmap (\(FieldType _ t) -> getTvarConstraint tvarName t) & Map.unions
+          fields & fmap (\(FieldType _ t) -> getRecordConstraints tvarName t) & Map.unions
 
         Just extName ->
           if extName == tvarName
             then fields & fmap (\(FieldType _ t) -> t)
             else Map.empty
 
+    TTuple a_ b Nothing  -> [a_, b]    & fmap (getRecordConstraints tvarName) & Map.unions
+    TTuple a_ b (Just c) -> [a_, b, c] & fmap (getRecordConstraints tvarName) & Map.unions
+
+    TAlias moduleName typeName tvars aType ->
+      let
+        aliasedTvarName =
+          case List.find (\(t,ti) -> ti == TVar tvarName) tvars of
+            Just (tvarNameNew, tvarType) -> tvarNameNew
+            Nothing -> tvarName
+      in
+
+      case aType of
+        Holey t ->
+          getRecordConstraints aliasedTvarName t
+          -- extractors & fmap (\extractor -> extractor t) & Map.unions
+
+        Filled t ->
+          getRecordConstraints aliasedTvarName t
+          -- extractors & fmap (\extractor -> extractor t) & Map.unions
+
     _ ->
       -- no constraint
       Map.empty
 
 
+renameTvars :: Data.Name.Name -> Data.Name.Name -> Type -> Type
+renameTvars oldName newName t =
+  case t of
+    TVar a ->
+      if a == oldName then TVar newName else t
+    TLambda t1 t2 -> TLambda (renameTvars oldName newName t1) (renameTvars oldName newName t2)
+    TType moduleName typeName params ->
+      TType moduleName typeName (fmap (renameTvars oldName newName) params)
+    TRecord fieldMap maybeName ->
+      fieldMap
+        & fmap (\(FieldType index tipe) ->
+            FieldType index (renameTvars oldName newName tipe)
+          )
+        & (\newFieldMap -> TRecord newFieldMap maybeName )
+    TUnit -> t
+    TTuple a b Nothing  -> TTuple (renameTvars oldName newName a) (renameTvars oldName newName b) Nothing
+    TTuple a b (Just c) -> TTuple (renameTvars oldName newName a) (renameTvars oldName newName b) (Just $ renameTvars oldName newName c)
+
+    TAlias moduleName typeName tvars (Holey tipe) ->
+      TAlias moduleName typeName (fmap (\(n,v) -> (n, renameTvars oldName newName t)) tvars) (Holey $ renameTvars oldName newName tipe)
+    TAlias moduleName typeName tvars (Filled tipe) ->
+      TAlias moduleName typeName (fmap (\(n,v) -> (n, renameTvars oldName newName t)) tvars) (Filled $ renameTvars oldName newName tipe)
+
+
+-- Flatten any TVar renames down through the type tree so that when we extract a constraint,
+-- all the TVars are consistent in the top level type signature we extract them for.
+normaliseTvarNames :: Map.Map Data.Name.Name Data.Name.Name -> Type -> Type
+normaliseTvarNames renames t =
+  -- debugHaskellPass "🔵 normaliseTvarNames" (renames, t) $
+  case t of
+    TVar a ->
+      case Map.lookup a renames of
+        Just newName -> TVar newName
+        Nothing -> t
+    TLambda t1 t2 -> TLambda (normaliseTvarNames renames t1) (normaliseTvarNames renames t2)
+    TType moduleName typeName params ->
+      TType moduleName typeName (fmap (normaliseTvarNames renames) params)
+    TRecord fieldMap maybeName ->
+      let newMaybeName =
+            case maybeName of
+              Just name ->
+                case Map.lookup name renames of
+                  Just newName -> Just newName
+                  Nothing -> maybeName
+              Nothing -> maybeName
+      in
+      fieldMap
+        & fmap (\(FieldType index tipe) ->
+            FieldType index (normaliseTvarNames renames tipe)
+          )
+        & (\newFieldMap -> TRecord newFieldMap newMaybeName )
+    TUnit -> t
+    TTuple a b Nothing  -> TTuple (normaliseTvarNames renames a) (normaliseTvarNames renames b) Nothing
+    TTuple a b (Just c) -> TTuple (normaliseTvarNames renames a) (normaliseTvarNames renames b) (Just $ normaliseTvarNames renames c)
+
+    TAlias moduleName typeName tvars atype ->
+      let
+        adjustTvars =
+          tvars & fmap (\x@(aliasName,v) ->
+            case v of
+              TVar originalName ->
+                let normalisedName =
+                      case Map.lookup originalName renames of
+                        Just newName -> newName
+                        Nothing -> originalName
+                in
+                if aliasName /= normalisedName
+                  -- we have a tvar rename, just write the tvar for now
+                  then (aliasName, TVar normalisedName)
+                  -- everything is aligned, carry on
+                  else x
+              _ -> x
+          )
+
+        newRenames =
+          adjustTvars & foldl (\acc (aliasName, v) ->
+            case v of
+              TVar originalName ->
+                if aliasName /= originalName
+                  then Map.insert aliasName originalName acc
+                  else acc
+              _ -> acc
+          ) Map.empty
+
+        newTvars =
+          adjustTvars & fmap (\x@(n,v) ->
+            case v of
+              TVar originalName -> (originalName, v)
+              _ -> x
+            )
+      in
+      case atype of
+        Holey tipe  -> TAlias moduleName typeName newTvars (Holey $ normaliseTvarNames newRenames tipe)
+        Filled tipe -> TAlias moduleName typeName newTvars (Filled $ normaliseTvarNames newRenames tipe)
+
+
 -- Sometimes a tvar is a constrained record (aka "extensible record"), and we need to
 -- generate a type signature that includes the constraint. This function takes a tvar
 -- name and a type, and if the type is a constrained record, it returns a new type
--- that includes the constraint. Otherwise it returns the original type.
+-- that includes the constraint. Otherwise it returns the original TVar.
 -- See Wire_Record_Extensible4_DB.elm for an example.
 constrainTvar :: Data.Name.Name -> Type -> Type
-constrainTvar tvar tipe =
-  -- debugHaskell ("🧡 constrainTvar") $
-  let constraints = getTvarConstraint tvar tipe
+constrainTvar tvarName tipe =
+  -- debugHaskellPassWhen (tvarName == "compatibleA") ("🧡 constrainTvar") (tvarName, tipe) $
+  let constraints = getRecordConstraints tvarName tipe
   in
   if Map.size constraints > 0 then
     constraints
       & Map.toList
       & imap (\i (name, t) -> (name, FieldType (fromIntegral i) t))
       & Map.fromList
-      & (\fields -> TRecord fields (Just tvar))
+      & (\fields -> TRecord fields (Just tvarName))
   else
-    TVar tvar
+    TVar tvarName
 
 
 encoderAlias :: Bool -> Map.Map Module.Raw I.Interface -> Pkg.Name -> Src.Module -> Decls -> Data.Name.Name -> Alias -> Def
@@ -446,8 +562,10 @@ encoderAlias isTest_ ifaces pkg modul decls aliasName alias@(Alias tvars tipe) =
     cname = Module.Canonical pkg (Src.getName modul)
     ptvars = tvars & fmap (\tvar -> pvar $ Data.Name.fromChars $ "w3_x_c_" ++ Data.Name.toChars tvar )
 
+    normalisedTvarsType = normaliseTvarNames Map.empty tipe
+
     ptvarsTyped = tvars & fmap (\tvar ->
-        let constrainedTvar = constrainTvar tvar tipe
+        let constrainedTvar = constrainTvar tvar normalisedTvarsType
         in
         ( pvar $ Data.Name.fromChars $ "w3_x_c_" ++ Data.Name.toChars tvar
         , TLambda constrainedTvar tLamdera_Wire_Encoder_Holey

diff --git a/extra/Lamdera/Wire3/Helpers.hs b/extra/Lamdera/Wire3/Helpers.hs
@@ -898,22 +898,6 @@ 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) ->

diff --git a/test/EasyTest.hs b/test/EasyTest.hs
@@ -136,6 +136,29 @@ expectEqualTextTrimmed expected actual =
           -- , T.pack $ show $ prettyEditExpr $ ediff (realExpected) (realActual)
           ]
 
+expectEqualFormat :: (Eq a, Show a) => a -> a -> Test ()
+expectEqualFormat expected actual =
+  if expected == actual
+    then
+      ok
+    else do
+      _ <- ensureBinaryIcdiff "icdiff"
+      diff <- liftIO $ do
+        icdiff (hindentFormatValue expected) (hindentFormatValue actual)
+
+      crash $
+        T.unpack $
+        T.unlines
+          [ ""
+          -- , "➡️  the result:"
+          -- , (realActual)
+          -- , "⬅️  did not equal expected value:"
+          -- , (realExpected)
+          , "💥💥💥"
+          , ""
+          , T.pack diff
+          -- , T.pack $ show $ prettyEditExpr $ ediff (realExpected) (realActual)
+          ]
 
 expectNotEqual :: (Eq a, Show a) => a -> a -> Test ()
 expectNotEqual forbidden actual =

diff --git a/test/Test/Wire.hs b/test/Test/Wire.hs
@@ -4,62 +4,91 @@
 
 module Test.Wire where
 
-
 import qualified Data.Map as Map
-import qualified Data.Set as Set
-import qualified Data.Text as Text
-import qualified Data.Utf8 as Utf8
-
-import qualified Elm.ModuleName as ModuleName
+import qualified Elm.ModuleName as Module
 import qualified Elm.Package as Pkg
 
 import Control.Concurrent.MVar
 import Control.Exception (SomeException, AsyncException(UserInterrupt), catch, fromException, throw)
-import System.Environment (lookupEnv)
 import System.FilePath ((</>))
 
 import EasyTest
 import Lamdera
-import Lamdera.Evergreen.Snapshot
-import NeatInterpolation
--- import qualified TestLamdera
 import qualified Lamdera.Compile
 
-import StandaloneInstances
-
--- Test all
-import qualified Reporting.Exit as Exit
-import qualified System.Exit as Exit
-import qualified Reporting.Task as Task
-import qualified Deps.Solver as Solver
-import qualified Deps.Registry
-
-import qualified BackgroundWriter as BW
-import qualified Elm.Outline as Outline
-import qualified Elm.Details as Details
-import qualified Install
-import qualified Reporting.Task as Task
-import qualified Reporting.Doc as D
-import qualified Elm.Version as V
-import qualified Elm.Constraint as C
-import qualified Stuff
-import qualified Reporting
-
-import qualified Init
-import qualified Make
-
--- http
-import qualified Json.Decode as D
-import qualified Lamdera.Http
-import qualified Ext.Common
+-- tests
+import qualified Lamdera.Wire3.Core
+import AST.Canonical
 
 all = EasyTest.run suite
 
 suite :: Test ()
 suite = tests $
   [ scope "compile all Elm wire expectations" wire
+  , scope "function tests" functions
   ]
 
+functions :: Test ()
+functions = do
+  let before =
+        TType
+            (Module.Canonical (Pkg.Name "elm" "core") "Maybe")
+            "Maybe"
+            [ TAlias
+                (Module.Canonical (Pkg.Name "author" "project") "Test.Wire_Record_Extensible5_ElmCss")
+                "Length"
+                [("compatible", TVar "compatibleB"), ("units", TVar "unit")]
+                (Holey
+                  (TAlias
+                      (Module.Canonical (Pkg.Name "author" "project") "Test.Wire_Record_Extensible5_ElmCss_External")
+                      "Length"
+                      [("compatible", TVar "compatible"), ("units", TVar "units")]
+                      (Holey
+                        (TRecord
+                            (Map.fromList
+                              [ ( "length"
+                                , FieldType
+                                    1
+                                    (TType (Module.Canonical (Pkg.Name "author" "project") "Test.Wire_Record_Extensible5_ElmCss_External") "Compatible" []))
+                              , ("numericValue", FieldType 2 (TType (Module.Canonical (Pkg.Name "elm" "core") "Basics") "Float" []))
+                              , ("unitLabel", FieldType 4 (TType (Module.Canonical (Pkg.Name "elm" "core") "String") "String" []))
+                              , ("units", FieldType 3 (TVar "units"))
+                              , ("value", FieldType 0 (TType (Module.Canonical (Pkg.Name "elm" "core") "String") "String" []))
+                              ])
+                            (Just "compatible")))))
+            ]
+
+      expected =
+        TType
+            (Module.Canonical (Pkg.Name "elm" "core") "Maybe")
+            "Maybe"
+            [ TAlias
+                (Module.Canonical (Pkg.Name "author" "project") "Test.Wire_Record_Extensible5_ElmCss")
+                "Length"
+                [("compatibleB", TVar "compatibleB"), ("unit", TVar "unit")]
+                (Holey
+                  (TAlias
+                      (Module.Canonical (Pkg.Name "author" "project") "Test.Wire_Record_Extensible5_ElmCss_External")
+                      "Length"
+                      [("compatibleB", TVar "compatibleB"), ("unit", TVar "unit")]
+                      (Holey
+                        (TRecord
+                            (Map.fromList
+                              [ ( "length"
+                                , FieldType
+                                    1
+                                    (TType (Module.Canonical (Pkg.Name "author" "project") "Test.Wire_Record_Extensible5_ElmCss_External") "Compatible" []))
+                              , ("numericValue", FieldType 2 (TType (Module.Canonical (Pkg.Name "elm" "core") "Basics") "Float" []))
+                              , ("unitLabel", FieldType 4 (TType (Module.Canonical (Pkg.Name "elm" "core") "String") "String" []))
+                              , ("units", FieldType 3 (TVar "unit"))
+                              , ("value", FieldType 0 (TType (Module.Canonical (Pkg.Name "elm" "core") "String") "String" []))
+                              ])
+                            (Just "compatibleB")))))
+            ]
+
+  expectEqualFormat expected (Lamdera.Wire3.Core.normaliseTvarNames Map.empty before)
+
+
 wire :: Test ()
 wire = do
 
@@ -92,6 +121,7 @@ wire = do
           , "src/Test/Wire_Record_Extensible2_MultiParam.elm"
           , "src/Test/Wire_Record_Extensible3_Tricky.elm"
           , "src/Test/Wire_Record_Extensible4_DB.elm"
+          , "src/Test/Wire_Record_Extensible5_ElmCss.elm"
           , "src/Test/Wire_Phantom.elm"
           , "src/Test/Wire_Tvar_Deep.elm"
           , "src/Test/Wire_Tvar_Deep2.elm"