diff --git a/src/Juvix/Compiler/Internal/Data/InstanceInfo.hs b/src/Juvix/Compiler/Internal/Data/InstanceInfo.hs index f55a84b4b2..b8af4336d4 100644 --- a/src/Juvix/Compiler/Internal/Data/InstanceInfo.hs +++ b/src/Juvix/Compiler/Internal/Data/InstanceInfo.hs @@ -27,22 +27,43 @@ data InstanceInfo = InstanceInfo _instanceInfoResult :: Expression, _instanceInfoArgs :: [FunctionParameter] } + deriving stock (Eq) + +instance Hashable InstanceInfo where + hashWithSalt salt InstanceInfo {..} = hashWithSalt salt _instanceInfoResult -- | Maps trait names to available instances -type InstanceTable = HashMap InductiveName [InstanceInfo] +newtype InstanceTable = InstanceTable + { _instanceTableMap :: HashMap InductiveName [InstanceInfo] + } makeLenses ''InstanceApp makeLenses ''InstanceInfo +makeLenses ''InstanceTable + +instance Semigroup InstanceTable where + t1 <> t2 = + InstanceTable $ + HashMap.unionWith combine (t1 ^. instanceTableMap) (t2 ^. instanceTableMap) + where + combine :: [InstanceInfo] -> [InstanceInfo] -> [InstanceInfo] + combine ii1 ii2 = nubHashable (ii1 ++ ii2) + +instance Monoid InstanceTable where + mempty = InstanceTable mempty updateInstanceTable :: InstanceTable -> InstanceInfo -> InstanceTable updateInstanceTable tab ii@InstanceInfo {..} = - HashMap.alter go _instanceInfoInductive tab + over instanceTableMap (HashMap.alter go _instanceInfoInductive) tab where go :: Maybe [InstanceInfo] -> Maybe [InstanceInfo] go = \case Just is -> Just (ii : is) Nothing -> Just [ii] +lookupInstanceTable :: InstanceTable -> Name -> Maybe [InstanceInfo] +lookupInstanceTable tab name = HashMap.lookup name (tab ^. instanceTableMap) + paramToExpression :: InstanceParam -> Expression paramToExpression = \case InstanceParamVar v -> diff --git a/src/Juvix/Compiler/Internal/Extra/DependencyBuilder.hs b/src/Juvix/Compiler/Internal/Extra/DependencyBuilder.hs index 8a15eb817e..1062754301 100644 --- a/src/Juvix/Compiler/Internal/Extra/DependencyBuilder.hs +++ b/src/Juvix/Compiler/Internal/Extra/DependencyBuilder.hs @@ -84,12 +84,15 @@ goModuleNoVisited (ModuleIndex m) = do goImport :: (Members '[Reader ExportsTable, State DependencyGraph, State StartNodes, Visit ModuleIndex] r) => Import -> Sem r () goImport (Import m) = visit m --- | Ignores includes -goPreModule :: (Members '[Reader ExportsTable, State DependencyGraph, State StartNodes] r) => PreModule -> Sem r () +goPreModule :: (Members '[Reader ExportsTable, State DependencyGraph, State StartNodes, Visit ModuleIndex] r) => PreModule -> Sem r () goPreModule m = do checkStartNode (m ^. moduleName) let b = m ^. moduleBody mapM_ (goPreStatement (m ^. moduleName)) (b ^. moduleStatements) + -- We cannot ignore imports with instances, because a trait in a module M may + -- depend on an instance in a module N which imports M (i.e. new edges may be + -- added from definitions in M to definitions in N) + mapM_ goImport (b ^. moduleImports) goStatement :: forall r. (Members '[Reader ExportsTable, State DependencyGraph, State StartNodes] r) => Name -> Statement -> Sem r () goStatement parentModule = \case diff --git a/src/Juvix/Compiler/Internal/Pretty/Base.hs b/src/Juvix/Compiler/Internal/Pretty/Base.hs index 6db5c3d639..6070f3e495 100644 --- a/src/Juvix/Compiler/Internal/Pretty/Base.hs +++ b/src/Juvix/Compiler/Internal/Pretty/Base.hs @@ -7,6 +7,7 @@ where import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Internal.Data.InfoTable.Base +import Juvix.Compiler.Internal.Data.InstanceInfo (instanceInfoResult, instanceTableMap) import Juvix.Compiler.Internal.Data.NameDependencyInfo import Juvix.Compiler.Internal.Extra import Juvix.Compiler.Internal.Pretty.Options @@ -313,6 +314,7 @@ instance PrettyCode InfoTable where inds <- ppCode (HashMap.keys (tbl ^. infoInductives)) constrs <- ppCode (HashMap.keys (tbl ^. infoConstructors)) funs <- ppCode (HashMap.keys (tbl ^. infoFunctions)) + insts <- ppCode $ map (map (^. instanceInfoResult)) $ HashMap.elems (tbl ^. infoInstances . instanceTableMap) let header :: Text -> Doc Ann = annotate AnnImportant . pretty return $ header "InfoTable" @@ -323,6 +325,8 @@ instance PrettyCode InfoTable where <> constrs <> header "\nFunctions: " <> funs + <> header "\nInstances: " + <> insts ppPostExpression :: (PrettyCode a, HasAtomicity a, Member (Reader Options) r) => diff --git a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Traits/Resolver.hs b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Traits/Resolver.hs index 369c86275d..43e69022c8 100644 --- a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Traits/Resolver.hs +++ b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Traits/Resolver.hs @@ -83,7 +83,7 @@ lookupInstance' :: [InstanceParam] -> Sem r [(InstanceInfo, SubsI)] lookupInstance' tab name params = do - let is = fromMaybe [] $ HashMap.lookup name tab + let is = fromMaybe [] $ lookupInstanceTable tab name mapMaybeM matchInstance is where matchInstance :: InstanceInfo -> Sem r (Maybe (InstanceInfo, SubsI)) diff --git a/test/Typecheck/Positive.hs b/test/Typecheck/Positive.hs index 574388939f..fcdc1ecfef 100644 --- a/test/Typecheck/Positive.hs +++ b/test/Typecheck/Positive.hs @@ -284,7 +284,11 @@ tests = posTest "Traits" $(mkRelDir ".") - $(mkRelFile "Traits.juvix") + $(mkRelFile "Traits.juvix"), + posTest + "Instance import" + $(mkRelDir "InstanceImport") + $(mkRelFile "Main.juvix") ] <> [ compilationTest t | t <- Compilation.tests ] diff --git a/tests/positive/InstanceImport/M.juvix b/tests/positive/InstanceImport/M.juvix new file mode 100644 index 0000000000..d4f51b545e --- /dev/null +++ b/tests/positive/InstanceImport/M.juvix @@ -0,0 +1,9 @@ +module M; + +trait +type T A := mkT {pp : A → A}; + +type Unit := unit; + +instance +unitI : T Unit := mkT λ {x := x}; diff --git a/tests/positive/InstanceImport/Main.juvix b/tests/positive/InstanceImport/Main.juvix new file mode 100644 index 0000000000..790e07913b --- /dev/null +++ b/tests/positive/InstanceImport/Main.juvix @@ -0,0 +1,12 @@ +module Main; + +import M open; +import M open; + +type Bool := true | false; + +instance +boolI : T Bool := mkT λ {x := x}; + +main : Bool := case T.pp unit + | unit := T.pp true; diff --git a/tests/positive/InstanceImport/juvix.yaml b/tests/positive/InstanceImport/juvix.yaml new file mode 100644 index 0000000000..e69de29bb2