diff --git a/src/Juvix/Compiler/Internal/Extra/InstanceInfo.hs b/src/Juvix/Compiler/Internal/Extra/InstanceInfo.hs index 225dc83495..6bff06ade4 100644 --- a/src/Juvix/Compiler/Internal/Extra/InstanceInfo.hs +++ b/src/Juvix/Compiler/Internal/Extra/InstanceInfo.hs @@ -45,18 +45,18 @@ makeRigidParam p = case p of InstanceParamMeta v -> InstanceParamVar v -paramToExpression :: InstanceParam -> Expression +paramToExpression :: (Member NameIdGen r) => InstanceParam -> Sem r Expression paramToExpression = \case InstanceParamVar v -> - ExpressionIden (IdenVar v) + return $ ExpressionIden (IdenVar v) InstanceParamApp InstanceApp {..} -> - _instanceAppExpression + return _instanceAppExpression InstanceParamFun InstanceFun {..} -> - _instanceFunExpression + return _instanceFunExpression InstanceParamHole h -> - ExpressionHole h + return $ ExpressionHole h InstanceParamMeta v -> - ExpressionIden (IdenVar v) + ExpressionHole . mkHole (getLoc v) <$> freshNameId paramFromExpression :: HashSet VarName -> Expression -> Maybe InstanceParam paramFromExpression metaVars e = case e of diff --git a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Error/Types.hs b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Error/Types.hs index 5904a157c1..a978aee564 100644 --- a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Error/Types.hs +++ b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Error/Types.hs @@ -101,9 +101,9 @@ instance ToGenericError UnsolvedMeta where mkMsg = do m <- holeid let loopMsg - | e ^. unsolvedIsLoop = Just "The inference algorithm found a loop." + | e ^. unsolvedIsLoop = Just (line <> "The inference algorithm found a loop.") | otherwise = Nothing - msg = "Unable to infer the hole" <>? loopMsg <>? m + msg = "Unable to infer the hole." <>? loopMsg <>? m return msg holeid :: Sem r (Maybe (Doc Ann)) holeid = runFail $ do 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 d3e2c04fab..b5085cbd7a 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 @@ -19,8 +19,8 @@ import Juvix.Prelude type SubsI = HashMap VarName InstanceParam -subsIToE :: SubsI -> Subs -subsIToE = fmap paramToExpression +subsIToE :: (Member NameIdGen r) => SubsI -> Sem r Subs +subsIToE = mapM paramToExpression type CoercionChain = [(CoercionInfo, SubsI)] @@ -41,8 +41,9 @@ resolveTraitInstance TypedHole {..} = do ty <- strongNormalize _typedHoleType is <- lookupInstance ctab tab (ty ^. normalizedExpression) case is of - [(cs, ii, subs)] -> - expandArity' loc (subsIToE subs) (ii ^. instanceInfoArgs) (ii ^. instanceInfoResult) + [(cs, ii, subs)] -> do + subs' <- subsIToE subs + expandArity' loc subs' (ii ^. instanceInfoArgs) (ii ^. instanceInfoResult) >>= applyCoercions loc cs [] -> throw (ErrNoInstance (NoInstance ty loc)) @@ -58,7 +59,7 @@ subsumingInstances :: InstanceInfo -> Sem r [(InstanceInfo)] subsumingInstances tab InstanceInfo {..} = do - is <- lookupInstance' [] False mempty tab _instanceInfoInductive (map makeRigidParam _instanceInfoParams) + is <- lookupInstance' [] mempty tab _instanceInfoInductive (map makeRigidParam _instanceInfoParams) return $ map snd3 $ filter (\(_, x, _) -> x ^. instanceInfoResult /= _instanceInfoResult) is @@ -72,7 +73,8 @@ substitutionI subs p = case p of InstanceParamVar {} -> return p InstanceParamApp InstanceApp {..} -> do args <- mapM (substitutionI subs) _instanceAppArgs - e <- substitutionE (subsIToE subs) _instanceAppExpression + subs' <- subsIToE subs + e <- substitutionE subs' _instanceAppExpression return $ InstanceParamApp InstanceApp @@ -83,7 +85,8 @@ substitutionI subs p = case p of InstanceParamFun InstanceFun {..} -> do l <- substitutionI subs _instanceFunLeft r <- substitutionI subs _instanceFunRight - e <- substitutionE (subsIToE subs) _instanceFunExpression + subs' <- subsIToE subs + e <- substitutionE subs' _instanceFunExpression return $ InstanceParamFun InstanceFun @@ -91,7 +94,12 @@ substitutionI subs p = case p of _instanceFunRight = r, _instanceFunExpression = e } - InstanceParamHole {} -> return p + InstanceParamHole h + | Just p' <- HashMap.lookup (varFromHole h) subs -> + -- we don't need to clone here because `InstanceParam` doesn't have binders + return p' + | otherwise -> + return p InstanceParamMeta v | Just p' <- HashMap.lookup v subs -> -- we don't need to clone here because `InstanceParam` doesn't have binders @@ -134,7 +142,8 @@ applyCoercion :: Expression -> Sem r Expression applyCoercion loc (CoercionInfo {..}, subs) e = do - e' <- expandArity' loc (subsIToE subs) _coercionInfoArgs _coercionInfoResult + subs' <- subsIToE subs + e' <- expandArity' loc subs' _coercionInfoArgs _coercionInfoResult return $ ExpressionApplication (Application e' e ImplicitInstance) @@ -180,15 +189,14 @@ expandArity loc subs params e = case params of lookupInstance' :: forall r. - (Members '[Inference, NameIdGen] r) => + (Members '[NameIdGen] r) => [Name] -> - Bool -> CoercionTable -> InstanceTable -> Name -> [InstanceParam] -> Sem r [(CoercionChain, InstanceInfo, SubsI)] -lookupInstance' visited canFillHoles ctab tab name params +lookupInstance' visited ctab tab name params | name `elem` visited = return [] | otherwise = do let is = fromMaybe [] $ lookupInstanceTable tab name @@ -204,7 +212,7 @@ lookupInstance' visited canFillHoles ctab tab name params failUnless (length params == length _instanceInfoParams) (si, b) <- runState mempty $ - and <$> sequence (zipWithExact goMatch _instanceInfoParams params) + and <$> sequence (zipWithExact (goMatch True) _instanceInfoParams params) failUnless b return ([], ii, si) @@ -213,7 +221,7 @@ lookupInstance' visited canFillHoles ctab tab name params failUnless (length params == length _coercionInfoParams) (si, b) <- runState mempty $ - and <$> sequence (zipWithExact goMatch _coercionInfoParams params) + and <$> sequence (zipWithExact (goMatch True) _coercionInfoParams params) failUnless b let name' = _coercionInfoTarget ^. instanceAppHead args' <- mapM (substitutionI si) (_coercionInfoTarget ^. instanceAppArgs) @@ -221,49 +229,46 @@ lookupInstance' visited canFillHoles ctab tab name params if | _coercionInfoDecreasing -> visited | otherwise -> name : visited - is <- lookupInstance' visited' canFillHoles ctab tab name' args' + is <- lookupInstance' visited' ctab tab name' args' return $ map (first3 ((ci, si) :)) is - goMatch :: InstanceParam -> InstanceParam -> Sem (State SubsI ': Fail ': r) Bool - goMatch pat t = case (pat, t) of - (InstanceParamMeta v, _) -> - goMatchMeta v t - (_, InstanceParamMeta v) -> - goMatchMeta v pat + goMatch :: Bool -> InstanceParam -> InstanceParam -> Sem (State SubsI ': Fail ': r) Bool + goMatch assignMetas pat t = case (pat, t) of + (InstanceParamMeta v, _) + | assignMetas -> + goMatchMeta v t + | otherwise -> + return True + (_, InstanceParamMeta {}) -> + return True + (_, InstanceParamHole {}) -> + return True (InstanceParamVar v1, InstanceParamVar v2) | v1 == v2 -> return True - (InstanceParamHole h, _) - | canFillHoles && checkNoMeta t -> do - m <- matchTypes (ExpressionHole h) (paramToExpression t) - case m of - Just {} -> return False - Nothing -> return True - | otherwise -> - return False - (_, InstanceParamHole h) - | canFillHoles && checkNoMeta pat -> do - m <- matchTypes (paramToExpression pat) (ExpressionHole h) - case m of - Just {} -> return False - Nothing -> return True (InstanceParamApp app1, InstanceParamApp app2) | app1 ^. instanceAppHead == app2 ^. instanceAppHead -> do - and <$> sequence (zipWithExact goMatch (app1 ^. instanceAppArgs) (app2 ^. instanceAppArgs)) + and <$> sequence (zipWithExact (goMatch assignMetas) (app1 ^. instanceAppArgs) (app2 ^. instanceAppArgs)) (InstanceParamFun fun1, InstanceParamFun fun2) -> do - l <- goMatch (fun1 ^. instanceFunLeft) (fun2 ^. instanceFunLeft) - r <- goMatch (fun1 ^. instanceFunRight) (fun2 ^. instanceFunRight) + l <- goMatch assignMetas (fun1 ^. instanceFunLeft) (fun2 ^. instanceFunLeft) + r <- goMatch assignMetas (fun1 ^. instanceFunRight) (fun2 ^. instanceFunRight) return $ l && r (InstanceParamVar {}, _) -> return False (InstanceParamApp {}, _) -> return False (InstanceParamFun {}, _) -> return False + (InstanceParamHole {}, _) -> return False goMatchMeta :: VarName -> InstanceParam -> Sem (State SubsI ': Fail ': r) Bool goMatchMeta v t = do m <- gets (HashMap.lookup v) case m of - Just t' -> - return (t' == t) + Just t' + | t' == t -> + return True + | otherwise -> + -- Here, we need to match without assigning meta-variables to + -- avoid possible infinite loops + goMatch False t' t Nothing -> do modify (HashMap.insert v t) return True @@ -278,6 +283,6 @@ lookupInstance :: lookupInstance ctab tab ty = case traitFromExpression mempty ty of Just InstanceApp {..} -> - lookupInstance' [] False ctab tab _instanceAppHead _instanceAppArgs + lookupInstance' [] ctab tab _instanceAppHead _instanceAppArgs _ -> return [] diff --git a/test/Typecheck/Negative.hs b/test/Typecheck/Negative.hs index b25edea502..4d8208f59f 100644 --- a/test/Typecheck/Negative.hs +++ b/test/Typecheck/Negative.hs @@ -217,6 +217,13 @@ tests = $ \case ErrTraitNotTerminating {} -> Nothing _ -> wrongError, + negTest + "Instance search termination" + $(mkRelDir "Internal") + $(mkRelFile "InstanceSearchTermination.juvix") + $ \case + ErrUnsolvedMeta {} -> Nothing + _ -> wrongError, negTest "Default value wrong type" $(mkRelDir "Internal") diff --git a/tests/Compilation/positive/out/test061.out b/tests/Compilation/positive/out/test061.out index ebfc489bee..0472a76c70 100644 --- a/tests/Compilation/positive/out/test061.out +++ b/tests/Compilation/positive/out/test061.out @@ -14,3 +14,4 @@ abba3 a :: b :: c :: d :: nil \{ true := false | false := true } 3, 1 :: 2 :: nil +6 diff --git a/tests/Compilation/positive/test061.juvix b/tests/Compilation/positive/test061.juvix index 0fc77ee840..68f06d61ed 100644 --- a/tests/Compilation/positive/test061.juvix +++ b/tests/Compilation/positive/test061.juvix @@ -104,4 +104,9 @@ main : IO := >>> printStringLn (f5 "abba" 3) >>> printStringLn (Show.show {{_}} ["a"; "b"; "c"; "d"]) >>> printStringLn (Show.show λ {x := not x}) - >>> printStringLn (Show.show (3, [1; 2 + T.a 0])); + >>> printStringLn (Show.show (3, [1; 2 + T.a 0])) + >>> (for (acc := 0) ((x, _) in [1, 1; 2, 2; 3, 3]) { + acc + x + } + |> Show.show + |> printStringLn); diff --git a/tests/Compilation/positive/test091.juvix b/tests/Compilation/positive/test091.juvix index 5769a2e9ce..54c1e5cff8 100644 --- a/tests/Compilation/positive/test091.juvix +++ b/tests/Compilation/positive/test091.juvix @@ -233,7 +233,7 @@ Identity-Monad : Monad Identity := readAndAdd {E : Type -> Type} {{Monad E}} {{Reader Nat E}} {{State Nat E}} : E Nat := do { - s <- Reader.ask {Nat}; + s <- Reader.ask; modify ((+) s); State.get }; diff --git a/tests/negative/Internal/InstanceSearchTermination.juvix b/tests/negative/Internal/InstanceSearchTermination.juvix new file mode 100644 index 0000000000..b489315669 --- /dev/null +++ b/tests/negative/Internal/InstanceSearchTermination.juvix @@ -0,0 +1,25 @@ +module InstanceSearchTermination; + +import Stdlib.Prelude open; + +trait +type T1 A B C := mkT1; + +trait +type T2 A B := mkT2; + +trait +type T3 A := mkT3; + +coercion instance +coe1 {A B} {{T2 A B}} : T3 A := mkT3; + +coercion instance +coe2 {A B} {{T1 A A A}} : T2 B A := mkT2; + +instance +inst1 {A} : T1 A (List A) (List A) := mkT1; + +f {A} {{T3 A}} : A -> A := id; + +main : Nat := f 0;