Track module's package to prevent Types module collision

ext-common/Ext/Query/Canonical.hs

@@ -51,10 +51,11 @@ loadSingleObjects path = do
 loadSingleArtifacts :: FilePath -> IO Compile.Artifacts
 loadSingleArtifacts path = do
   ifaces <- Ext.Query.Interfaces.all [path]
+  let ifacesRaw = Map.mapKeys Module._module ifaces
   source <- File.readUtf8 path
   case Parse.fromByteString Parse.Application source of
     Right modul ->
-      case Compile.compile Nothing Pkg.dummyName ifaces modul of
+      case Compile.compile Nothing Pkg.dummyName ifacesRaw modul of
         Right artifacts ->
           pure artifacts
 

ext-common/Ext/Query/Interfaces.hs

@@ -6,7 +6,6 @@ module Ext.Query.Interfaces where
 
 import Control.Monad (liftM2)
 import qualified Data.Map as Map
-import qualified Data.OneOrMore as OneOrMore
 import Control.Concurrent.MVar
 
 import qualified Data.NonEmptyList as NE
@@ -15,6 +14,7 @@ import qualified AST.Optimized as Opt
 import qualified Elm.Details as Details
 import qualified Elm.Interface as I
 import qualified Elm.ModuleName as ModuleName
+import qualified Elm.Package as Pkg
 import qualified Reporting
 import qualified Reporting.Exit as Exit
 import qualified Reporting.Task as Task
@@ -26,7 +26,7 @@ import qualified Json.Encode as Encode
 import Ext.Common
 
 
-all :: [FilePath] -> IO (Map.Map ModuleName.Raw I.Interface)
+all :: [FilePath] -> IO (Map.Map ModuleName.Canonical I.Interface)
 all paths = do
   debug $ "Loading Interfaces.all on paths: " ++ show paths
   artifactsDeps <- allDepArtifacts
@@ -39,7 +39,7 @@ all paths = do
 
 
 -- Takes Build.Artifacts and extracts project interfaces, loads all package dep interfaces, and merges them
-artifactsToFullInterfaces :: Details.Details -> Build.Artifacts -> IO (Map.Map ModuleName.Raw I.Interface)
+artifactsToFullInterfaces :: Details.Details -> Build.Artifacts -> IO (Map.Map ModuleName.Canonical I.Interface)
 artifactsToFullInterfaces details artifacts = do
 
   ifaces <- extractInterfaces $ Build._modules artifacts
@@ -57,7 +57,7 @@ allGraph = do
 
 data Artifacts =
   Artifacts
-    { _ifaces :: Map.Map ModuleName.Raw I.Interface
+    { _ifaces :: Map.Map ModuleName.Canonical I.Interface
     , _graph :: Opt.GlobalGraph
     }
 
@@ -97,27 +97,26 @@ allDepArtifacts_ details = do
       return $ Artifacts (toInterfaces deps) objs
 
 
-toInterfaces :: Map.Map ModuleName.Canonical I.DependencyInterface -> Map.Map ModuleName.Raw I.Interface
+toInterfaces :: Map.Map ModuleName.Canonical I.DependencyInterface -> Map.Map ModuleName.Canonical I.Interface
 toInterfaces deps =
-  Map.mapMaybe toUnique $ Map.fromListWith OneOrMore.more $
-    Map.elems (Map.mapMaybeWithKey getPublic deps)
+  Map.map toInterface deps
 
 
-getPublic :: ModuleName.Canonical -> I.DependencyInterface -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore I.Interface)
-getPublic (ModuleName.Canonical _ name) dep =
+toInterface :: I.DependencyInterface -> I.Interface
+toInterface dep =
   case dep of
-    I.Public  iface -> Just (name, OneOrMore.one iface)
-    I.Private _ _ _ -> Nothing
-
-
-toUnique :: OneOrMore.OneOrMore a -> Maybe a
-toUnique oneOrMore =
-  case oneOrMore of
-    OneOrMore.One value -> Just value
-    OneOrMore.More _ _  -> Nothing
-
-
-allProjectInterfaces :: NE.List FilePath -> IO (Map.Map ModuleName.Raw I.Interface)
+    I.Public iface -> iface
+    I.Private pkg unions aliases ->
+      I.Interface
+        { I._home = pkg
+        , I._values = Map.empty
+        , I._unions = Map.map I.PrivateUnion unions
+        , I._aliases = Map.map I.PrivateAlias aliases
+        , I._binops = Map.empty
+        }
+
+
+allProjectInterfaces :: NE.List FilePath -> IO (Map.Map ModuleName.Canonical I.Interface)
 allProjectInterfaces paths =
   BW.withScope $ \scope -> do
     root <- getProjectRoot "allProjectInterfaces"
@@ -146,7 +145,7 @@ runTaskUnsafe task = do
             \\n" ++ (exit & Exit.reactorToReport & Exit.toJson & Encode.encode & builderToString)
 
 
-extractInterfaces :: [Build.Module] -> IO (Map.Map ModuleName.Raw I.Interface)
+extractInterfaces :: [Build.Module] -> IO (Map.Map ModuleName.Canonical I.Interface)
 extractInterfaces modu = do
   k <- modu
     & mapM (\m ->
@@ -156,7 +155,7 @@ extractInterfaces modu = do
         Build.Cached name _ mCachedInterface ->
           cachedHelp name mCachedInterface
     )
-  pure $ Map.fromList $ justs k
+  pure $ Map.fromList $ fmap (\(nameRaw, iface) -> (ModuleName.Canonical Pkg.dummyName nameRaw, iface)) $ justs k
 
 
 {- Appropriated from Build.loadInterface -}

ext-elm-pages/Ext/ElmPages.hs

@@ -65,7 +65,7 @@ data DiffableType
 
 checkPageDataType :: Interfaces -> Either Reporting.Exit.BuildProblem ()
 checkPageDataType interfaces =
-  case Map.lookup "Main" interfaces of
+  case Map.lookup (ModuleName.Canonical Pkg.dummyName "Main") interfaces of
     Just targetInterface ->
       if typeExists "PageData" targetInterface
         then do
@@ -125,19 +125,15 @@ wireError formattedErrors =
 
 {- Tracks types that have already been seen to ensure we can break cycles -}
 type RecursionSet =
-  Set.Set (ModuleName.Raw, N.Name, [Can.Type])
-
-
-nameRaw :: ModuleName.Canonical -> ModuleName.Raw
-nameRaw (ModuleName.Canonical (Pkg.Name author pkg) module_) = module_
+  Set.Set (ModuleName.Canonical, N.Name, [Can.Type])
 
 
 diffableTypeByName :: Interfaces -> N.Name -> ModuleName.Canonical -> Interface.Interface -> DiffableType
 diffableTypeByName interfaces targetName modul interface = do
   let
     moduleName = ModuleName._module modul
     currentModule = modul
-    recursionSet = Set.singleton (moduleName, targetName, [])
+    recursionSet = Set.singleton (modul, targetName, [])
 
   case Map.lookup targetName $ Interface._aliases interface of
     Just alias -> do
@@ -228,7 +224,7 @@ canonicalToDiffableType targetName currentModule interfaces recursionSet canonic
       let
         currentModule_ = moduleName
 
-        recursionIdentifier = (nameRaw moduleName, name, tvarResolvedParams)
+        recursionIdentifier = (moduleName, name, tvarResolvedParams)
 
         newRecursionSet = Set.insert recursionIdentifier recursionSet
 
@@ -367,7 +363,7 @@ canonicalToDiffableType targetName currentModule interfaces recursionSet canonic
         (author, pkg, module_, tipe) ->
           -- Anything else must not be a core type, recurse to find it
 
-          case Map.lookup (nameRaw moduleName) interfaces of
+          case Map.lookup moduleName interfaces of
             Just subInterface ->
 
               -- Try unions

extra/Lamdera/Evergreen/MigrationGenerator.hs

@@ -43,10 +43,10 @@ betweenVersions coreTypeDiffs oldVersion newVersion root = do
 
     res <- Ext.Common.withProjectRoot root $ do
       interfaces <- Ext.Query.Interfaces.all (NE.toList paths)
-      case Map.lookup (N.fromChars moduleNameString) interfaces of
+      case Map.lookup (ModuleName.Canonical Pkg.dummyName (N.fromChars moduleNameString)) interfaces of
         Just interface -> do
           debug $ "starting generatefor"
-          generateFor coreTypeDiffs oldVersion newVersion interfaces (interfaces Sanity.! (N.fromChars $ "Evergreen.V" <> show newVersion <> ".Types"))
+          generateFor coreTypeDiffs oldVersion newVersion interfaces (interfaces Sanity.! (ModuleName.Canonical Pkg.dummyName (N.fromChars $ "Evergreen.V" <> show newVersion <> ".Types")))
 
         Nothing ->
           error $ "Fatal: could not find the module `" <> moduleNameString <> "`, please report this issue in Discord with your project code."

extra/Lamdera/Evergreen/MigrationGeneratorHelpers.hs

@@ -601,7 +601,7 @@ findTypeDef tipe interfaces =
 
 findDef :: ModuleName.Canonical -> N.Name -> Interfaces -> Maybe TypeDef
 findDef moduleNameCan typeName interfaces =
-  case Map.lookup (dropCan moduleNameCan) interfaces of
+  case Map.lookup moduleNameCan interfaces of
     Just moduleInterface ->
       findDef_ moduleNameCan typeName moduleInterface
 

extra/Lamdera/Evergreen/Snapshot.hs

@@ -47,7 +47,7 @@ type snapshots  -}
 run :: Int -> IO ()
 run version = do
   ifaces <- Interfaces.all [ "src/Types.elm" ]
-  snapshotCurrentTypes version ifaces (ifaces ! "Types")
+  snapshotCurrentTypes version ifaces (ifaces ! ModuleName.Canonical Pkg.dummyName "Types")
 
 
 snapshotCurrentTypes :: Int -> Interfaces -> Interface.Interface -> IO ()
@@ -665,7 +665,7 @@ canonicalToFt version scope interfaces recursionSet canonical tvarMap =
         (author, pkg, module_, tipe) ->
           -- Anything else must not be a core type, recurse to find it
 
-          case Map.lookup moduleNameRaw interfaces of
+          case Map.lookup moduleName interfaces of
             Just subInterface ->
 
               -- Try unions

extra/Lamdera/Make.hs

@@ -25,8 +25,8 @@ import qualified Ext.Query.Interfaces
 
 
 
--- compileToInterfaces :: FilePath -> FilePath -> IO (Map.Map ModuleName.Raw I.Interface)
-compileToInterfaces :: FilePath -> FilePath -> [FilePath] -> IO (Either Exit.Make (Map.Map ModuleName.Raw I.Interface))
+-- compileToInterfaces :: FilePath -> FilePath -> IO (Map.Map ModuleName.Canonical I.Interface)
+compileToInterfaces :: FilePath -> FilePath -> [FilePath] -> IO (Either Exit.Make (Map.Map ModuleName.Canonical I.Interface))
 compileToInterfaces root path additional = do
   Ext.Common.withProjectRoot root $ do
     let

extra/Lamdera/TypeHash.hs

@@ -80,13 +80,13 @@ buildCheckHashes artifacts = do
 
 {- Tracks types that have already been seen to ensure we can break cycles -}
 type RecursionSet =
-  Set.Set (ModuleName.Raw, N.Name, [Type])
+  Set.Set (ModuleName.Canonical, N.Name, [Type])
 
 
 calculateHashPair :: FilePath -> N.Name -> N.Name -> IO (Text, Text)
 calculateHashPair path modulename typename = do
   interfaces <- Interfaces.all [ path ]
-  case Map.lookup modulename interfaces of
+  case Map.lookup (ModuleName.Canonical Pkg.dummyName modulename) interfaces of
     Just interfaceModule -> do
       let dt = diffableTypeByName interfaces typename modulename interfaceModule
       pure $ (diffableTypeToHash dt, diffableTypeToText dt)
@@ -99,7 +99,7 @@ calculateLamderaHashes = do
   debug $ "#️⃣  typehash: full with interface load"
   interfaces <- Interfaces.all [ "src/Types.elm" ]
   inDebug <- Lamdera.isDebug
-  case Map.lookup "Types" interfaces of
+  case Map.lookup (ModuleName.Canonical Pkg.dummyName "Types") interfaces of
     Just iface_Types ->
       calculateLamderaHashes_ interfaces iface_Types inDebug
 
@@ -172,7 +172,7 @@ calculateLamderaHashes_ interfaces iface_Types inDebug = do
 diffableTypeByName :: Interfaces -> N.Name -> N.Name -> Interface.Interface -> DiffableType
 diffableTypeByName interfaces targetName moduleName interface = do
   let
-    recursionSet = Set.singleton (moduleName, targetName, [])
+    recursionSet = Set.singleton (ModuleName.Canonical Pkg.dummyName moduleName, targetName, [])
 
   case Map.lookup targetName $ Interface._aliases interface of
     Just alias -> do
@@ -240,8 +240,6 @@ aliasToDiffableType targetName interfaces recursionSet tvarMap aliasInterface pa
     Interface.PublicAlias a -> treat a
     Interface.PrivateAlias a -> treat a
 
-nameRaw (ModuleName.Canonical (Pkg.Name author pkg) module_) = module_
-
 -- = TLambda Type Type
 -- | TVar N.Name
 -- | TType ModuleName.Canonical N.Name [Type]
@@ -254,7 +252,7 @@ canonicalToDiffableType targetName interfaces recursionSet canonical tvarMap =
   case canonical of
     TType moduleName name params ->
       let
-        recursionIdentifier = (nameRaw moduleName, name, tvarResolvedParams)
+        recursionIdentifier = (moduleName, name, tvarResolvedParams)
 
         newRecursionSet = Set.insert recursionIdentifier recursionSet
 
@@ -420,7 +418,7 @@ canonicalToDiffableType targetName interfaces recursionSet canonical tvarMap =
         (author, pkg, module_, tipe) ->
           -- Anything else must not be a core type, recurse to find it
 
-          case Map.lookup (nameRaw moduleName) interfaces of
+          case Map.lookup moduleName interfaces of
             Just subInterface ->
 
               -- Try unions

extra/Lamdera/Types.hs

@@ -11,7 +11,7 @@ import qualified Elm.ModuleName as ModuleName
 import Lamdera
 
 type Interfaces =
-  Map.Map ModuleName.Raw Interface.Interface
+  Map.Map ModuleName.Canonical Interface.Interface
 
 
 data DiffableType

test/Test/TypeHashes.hs

@@ -123,6 +123,22 @@ suite = tests
         expectEqualTextTrimmed thash "4684f0e30ca7421c497e79b5dfc88cec77010699"
         expectEqualTextTrimmed ttext "R[LD[C[[][]],S]LS[C[[][]]]]"
 
+      scope "package type aliasing its internal Types module (miyamoen/select-list)" $ do
+        -- Regression test: miyamoen/select-list's SelectList.SelectList is a
+        -- type alias for its internal Types.SelectList. The Types module gets
+        -- confused with user's Types module. Tracking the package properly is
+        -- needed to distinguish the two.
+        project_ <- io $ Lamdera.Relative.requireDir "test/scenario-select-list"
+        let
+          modulePath = "src/Test/Wire_Package_Types_SelectList.elm"
+          moduleName = "Test.Wire_Package_Types_SelectList"
+          typeName = "PackageTypesSelectList"
+
+        (thash, ttext) <- ioSilenced $ withDebug $ Ext.Common.withProjectRoot project_ $ do
+          Lamdera.TypeHash.calculateHashPair modulePath moduleName typeName
+
+        expectEqualTextTrimmed ttext "C[[L[I]IL[I]]]"
+
 
   , scope "sha1 should not collide" $ do
 

test/scenario-select-list/elm.json

@@ -0,0 +1,19 @@
+{
+    "type": "application",
+    "source-directories": [
+        "src"
+    ],
+    "elm-version": "0.19.1",
+    "dependencies": {
+        "direct": {
+            "elm/core": "1.0.5",
+            "elm/json": "1.1.3",
+            "miyamoen/select-list": "4.1.0"
+        },
+        "indirect": {}
+    },
+    "test-dependencies": {
+        "direct": {},
+        "indirect": {}
+    }
+}

test/scenario-select-list/src/Test/Wire_Package_Types_SelectList.elm

@@ -0,0 +1,7 @@
+module Test.Wire_Package_Types_SelectList exposing (..)
+
+import SelectList exposing (SelectList)
+
+
+type alias PackageTypesSelectList =
+    SelectList Int

test/scenario-select-list/src/Types.elm

@@ -0,0 +1,31 @@
+module Types exposing (..)
+
+{-| Lamdera app's Types module (as opposed to the SelectList's Types module -
+see elm.json in this test)
+-}
+
+
+type alias FrontendModel =
+    { message : String
+    }
+
+
+type alias BackendModel =
+    { message : String
+    }
+
+
+type FrontendMsg
+    = NoOpFrontendMsg
+
+
+type ToBackend
+    = NoOpToBackend
+
+
+type BackendMsg
+    = NoOpBackendMsg
+
+
+type ToFrontend
+    = NoOpToFrontend