diff --git a/ext-common/Ext/Query/Canonical.hs b/ext-common/Ext/Query/Canonical.hs index bf34f159d..3b1414300 100644 --- a/ext-common/Ext/Query/Canonical.hs +++ b/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 diff --git a/ext-common/Ext/Query/Interfaces.hs b/ext-common/Ext/Query/Interfaces.hs index aafee15cf..cb41e97c7 100644 --- a/ext-common/Ext/Query/Interfaces.hs +++ b/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 -} diff --git a/ext-elm-pages/Ext/ElmPages.hs b/ext-elm-pages/Ext/ElmPages.hs index 6cc3d72ae..6640cfcc3 100644 --- a/ext-elm-pages/Ext/ElmPages.hs +++ b/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,11 +125,7 @@ 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 @@ -137,7 +133,7 @@ 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 diff --git a/extra/Lamdera/Evergreen/MigrationGenerator.hs b/extra/Lamdera/Evergreen/MigrationGenerator.hs index 3bb7b3fa9..5a0b3f919 100644 --- a/extra/Lamdera/Evergreen/MigrationGenerator.hs +++ b/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." diff --git a/extra/Lamdera/Evergreen/MigrationGeneratorHelpers.hs b/extra/Lamdera/Evergreen/MigrationGeneratorHelpers.hs index 972caeb25..24f36c0b7 100644 --- a/extra/Lamdera/Evergreen/MigrationGeneratorHelpers.hs +++ b/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 diff --git a/extra/Lamdera/Evergreen/Snapshot.hs b/extra/Lamdera/Evergreen/Snapshot.hs index 0c54d98f9..028c212d4 100644 --- a/extra/Lamdera/Evergreen/Snapshot.hs +++ b/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 diff --git a/extra/Lamdera/Make.hs b/extra/Lamdera/Make.hs index 57ffb710b..5971ec554 100644 --- a/extra/Lamdera/Make.hs +++ b/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 diff --git a/extra/Lamdera/TypeHash.hs b/extra/Lamdera/TypeHash.hs index a29f0023e..48f4e9b6a 100644 --- a/extra/Lamdera/TypeHash.hs +++ b/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 diff --git a/extra/Lamdera/Types.hs b/extra/Lamdera/Types.hs index 446547e77..10967a9a6 100644 --- a/extra/Lamdera/Types.hs +++ b/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 diff --git a/test/Test/TypeHashes.hs b/test/Test/TypeHashes.hs index 47bac4704..e45753fea 100644 --- a/test/Test/TypeHashes.hs +++ b/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 diff --git a/test/scenario-select-list/elm.json b/test/scenario-select-list/elm.json new file mode 100644 index 000000000..66e5a72fa --- /dev/null +++ b/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": {} + } +} diff --git a/test/scenario-select-list/src/Test/Wire_Package_Types_SelectList.elm b/test/scenario-select-list/src/Test/Wire_Package_Types_SelectList.elm new file mode 100644 index 000000000..7c96fe5fc --- /dev/null +++ b/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 diff --git a/test/scenario-select-list/src/Types.elm b/test/scenario-select-list/src/Types.elm new file mode 100644 index 000000000..2a4b4ff74 --- /dev/null +++ b/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