From 2ad436b541d76445254863b35595ce1d8cc28f21 Mon Sep 17 00:00:00 2001 From: Arnaud BOEGLIN Date: Mon, 7 Nov 2022 21:01:09 +0100 Subject: [PATCH] feat: Wrap up exhaustive pattern check --- .../golden | 6 + .../golden | 6 + .../golden | 6 + .../golden | 8 +- .../golden | 8 +- .../golden | 6 + .../golden | 30 ++ .../golden | 6 + .../golden | 6 + .../golden | 6 + compiler/main/Driver/Rules.hs | 9 +- compiler/main/Infer/ExhaustivePatterns.hs | 386 ++++++++++-------- compiler/main/Run/LanguageServer.hs | 4 +- madlib.cabal | 2 +- package.yaml | 2 +- pkg/package.json | 2 +- prelude/__internal__/List.mad | 5 +- prelude/__internal__/Process.mad | 3 + 18 files changed, 315 insertions(+), 186 deletions(-) diff --git a/.snapshots/should_allow_deconstruction_of_lists/golden b/.snapshots/should_allow_deconstruction_of_lists/golden index 9f53b34ce..51fef9d7c 100644 --- a/.snapshots/should_allow_deconstruction_of_lists/golden +++ b/.snapshots/should_allow_deconstruction_of_lists/golden @@ -153,6 +153,12 @@ , apath = Just "Module.mad" } , [ CompilationWarning + (IncompletePattern [ "[]" ]) + Context + { ctxAstPath = "Module.mad" + , ctxArea = Area (Loc 4 1 5) (Loc 56 3 2) + } + , CompilationWarning (UnusedTopLevelDeclaration "x") Context { ctxAstPath = "Module.mad" diff --git a/.snapshots/should_correctly_infer_constructor_patterns_given_a_var/golden b/.snapshots/should_correctly_infer_constructor_patterns_given_a_var/golden index ef4543cba..fbf84a3e4 100644 --- a/.snapshots/should_correctly_infer_constructor_patterns_given_a_var/golden +++ b/.snapshots/should_correctly_infer_constructor_patterns_given_a_var/golden @@ -1387,6 +1387,12 @@ , apath = Just "Module.mad" } , [ CompilationWarning + (IncompletePattern [ "Nothing" ]) + Context + { ctxAstPath = "Module.mad" + , ctxArea = Area (Loc 48 4 3) (Loc 79 6 4) + } + , CompilationWarning (UnusedConstructor "Nothing") Context { ctxAstPath = "Module.mad" diff --git a/.snapshots/should_correctly_infer_types_of_record_pattern_when_the_input_has_a_variable_type/golden b/.snapshots/should_correctly_infer_types_of_record_pattern_when_the_input_has_a_variable_type/golden index a41ff3149..54d4391fa 100644 --- a/.snapshots/should_correctly_infer_types_of_record_pattern_when_the_input_has_a_variable_type/golden +++ b/.snapshots/should_correctly_infer_types_of_record_pattern_when_the_input_has_a_variable_type/golden @@ -135,6 +135,12 @@ , apath = Just "Module.mad" } , [ CompilationWarning + RedundantPattern + Context + { ctxAstPath = "Module.mad" + , ctxArea = Area (Loc 42 3 3) (Loc 50 3 11) + } + , CompilationWarning (UnusedTopLevelDeclaration "fn2") Context { ctxAstPath = "Module.mad" diff --git a/.snapshots/should_fail_to_resolve_a_constructor_pattern_with_different_type_variables_applied/golden b/.snapshots/should_fail_to_resolve_a_constructor_pattern_with_different_type_variables_applied/golden index f1f649360..2496c1801 100644 --- a/.snapshots/should_fail_to_resolve_a_constructor_pattern_with_different_type_variables_applied/golden +++ b/.snapshots/should_fail_to_resolve_a_constructor_pattern_with_different_type_variables_applied/golden @@ -1828,7 +1828,13 @@ ] , apath = Just "Module.mad" } -, [] +, [ CompilationWarning + RedundantPattern + Context + { ctxAstPath = "Module.mad" + , ctxArea = Area (Loc 125 7 5) (Loc 144 7 24) + } + ] , [ CompilationError (UnboundVariable "Integer") Context diff --git a/.snapshots/should_fail_to_resolve_if_the_given_constructor_does_not_exist/golden b/.snapshots/should_fail_to_resolve_if_the_given_constructor_does_not_exist/golden index 95bd09c54..9b8301866 100644 --- a/.snapshots/should_fail_to_resolve_if_the_given_constructor_does_not_exist/golden +++ b/.snapshots/should_fail_to_resolve_if_the_given_constructor_does_not_exist/golden @@ -65,7 +65,13 @@ , ainstances = [] , apath = Just "Module.mad" } -, [] +, [ CompilationWarning + RedundantPattern + Context + { ctxAstPath = "Module.mad" + , ctxArea = Area (Loc 45 3 3) (Loc 64 3 22) + } + ] , [ CompilationError (UnboundVariable "Integer") Context diff --git a/.snapshots/should_fail_to_resolve_patterns_of_different_types_for_list_items/golden b/.snapshots/should_fail_to_resolve_patterns_of_different_types_for_list_items/golden index 3988efe7b..dd293a354 100644 --- a/.snapshots/should_fail_to_resolve_patterns_of_different_types_for_list_items/golden +++ b/.snapshots/should_fail_to_resolve_patterns_of_different_types_for_list_items/golden @@ -109,6 +109,12 @@ , apath = Just "Module.mad" } , [ CompilationWarning + (IncompletePattern [ "[]" ]) + Context + { ctxAstPath = "Module.mad" + , ctxArea = Area (Loc 4 1 5) (Loc 63 4 2) + } + , CompilationWarning (UnusedTopLevelDeclaration "x") Context { ctxAstPath = "Module.mad" diff --git a/.snapshots/should_infer_complex_where_expressions_with_records/golden b/.snapshots/should_infer_complex_where_expressions_with_records/golden index 383ea9886..f0206614f 100644 --- a/.snapshots/should_infer_complex_where_expressions_with_records/golden +++ b/.snapshots/should_infer_complex_where_expressions_with_records/golden @@ -8706,6 +8706,36 @@ , apath = Just "Module.mad" } , [ CompilationWarning + RedundantPattern + Context + { ctxAstPath = "Module.mad" + , ctxArea = Area (Loc 867 37 5) (Loc 900 37 38) + } + , CompilationWarning + RedundantPattern + Context + { ctxAstPath = "Module.mad" + , ctxArea = Area (Loc 930 38 5) (Loc 967 38 42) + } + , CompilationWarning + RedundantPattern + Context + { ctxAstPath = "Module.mad" + , ctxArea = Area (Loc 997 39 5) (Loc 1031 39 39) + } + , CompilationWarning + (IncompletePattern + [ "#[{ ik: _ }, { ik: _ }]" + , "#[{ lui: _ }, { lui: _ }]" + , "#[{ name: _ }, { name: _ }]" + , "#[{ po: { pi: { nameD: _ } } }]" + , "#[{ tchouk: _ }, { tchouk: _ }]" + ]) + Context + { ctxAstPath = "Module.mad" + , ctxArea = Area (Loc 781 35 20) (Loc 1206 42 4) + } + , CompilationWarning (UnusedTopLevelDeclaration "generateFunctionLinks") Context { ctxAstPath = "Module.mad" diff --git a/.snapshots/should_resolve_basic_patterns_for_lists/golden b/.snapshots/should_resolve_basic_patterns_for_lists/golden index 86769eb72..5e221ab8b 100644 --- a/.snapshots/should_resolve_basic_patterns_for_lists/golden +++ b/.snapshots/should_resolve_basic_patterns_for_lists/golden @@ -505,6 +505,12 @@ , apath = Just "Module.mad" } , [ CompilationWarning + (IncompletePattern [ "[]" ]) + Context + { ctxAstPath = "Module.mad" + , ctxArea = Area (Loc 4 1 5) (Loc 103 6 2) + } + , CompilationWarning (UnusedTopLevelDeclaration "a") Context { ctxAstPath = "Module.mad" diff --git a/.snapshots/should_resolve_where_with_a_Integer_input/golden b/.snapshots/should_resolve_where_with_a_Integer_input/golden index c179850b6..04b3c6649 100644 --- a/.snapshots/should_resolve_where_with_a_Integer_input/golden +++ b/.snapshots/should_resolve_where_with_a_Integer_input/golden @@ -102,6 +102,12 @@ , apath = Just "Module.mad" } , [ CompilationWarning + (IncompletePattern [ "_" ]) + Context + { ctxAstPath = "Module.mad" + , ctxArea = Area (Loc 4 1 5) (Loc 75 6 2) + } + , CompilationWarning (UnusedTopLevelDeclaration "x") Context { ctxAstPath = "Module.mad" diff --git a/.snapshots/should_resolve_where_with_a_string_input/golden b/.snapshots/should_resolve_where_with_a_string_input/golden index d9a983b3b..d42b6c68b 100644 --- a/.snapshots/should_resolve_where_with_a_string_input/golden +++ b/.snapshots/should_resolve_where_with_a_string_input/golden @@ -107,6 +107,12 @@ , apath = Just "Module.mad" } , [ CompilationWarning + (IncompletePattern [ "_" ]) + Context + { ctxAstPath = "Module.mad" + , ctxArea = Area (Loc 4 1 5) (Loc 67 6 2) + } + , CompilationWarning (UnusedTopLevelDeclaration "x") Context { ctxAstPath = "Module.mad" diff --git a/compiler/main/Driver/Rules.hs b/compiler/main/Driver/Rules.hs index 9c6970945..0133fc4bd 100644 --- a/compiler/main/Driver/Rules.hs +++ b/compiler/main/Driver/Rules.hs @@ -231,7 +231,14 @@ rules options (Rock.Writer (Rock.Writer query)) = case query of ForeignTypeDeclaration modulePath name -> nonInput $ do (Slv.AST { Slv.atypedecls }, _) <- Rock.fetch $ SolvedASTWithEnv modulePath - return (List.find (\fullTd@(Slv.Untyped _ td) -> Slv.isADT fullTd && Slv.adtname td == name || Slv.isAlias fullTd && Slv.aliasname td == name) atypedecls, (mempty, mempty)) + return ( List.find + (\fullTd@(Slv.Untyped _ td) -> + Slv.isADT fullTd && Slv.adtname td == name + || Slv.isAlias fullTd && Slv.aliasname td == name + ) + atypedecls + , (mempty, mempty) + ) CoreAST path -> nonInput $ do (slvAst, _) <- Rock.fetch $ SolvedASTWithEnv path diff --git a/compiler/main/Infer/ExhaustivePatterns.hs b/compiler/main/Infer/ExhaustivePatterns.hs index 236365a2c..6deec655c 100644 --- a/compiler/main/Infer/ExhaustivePatterns.hs +++ b/compiler/main/Infer/ExhaustivePatterns.hs @@ -4,6 +4,7 @@ {-# HLINT ignore "Eta reduce" #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} module Infer.ExhaustivePatterns where @@ -32,6 +33,7 @@ import Text.Show.Pretty (ppShow) import Error.Warning import Error.Context import qualified Data.Set as Set +import Debug.Trace -- PATTERN @@ -41,8 +43,21 @@ data Pattern | Literal Literal | Ctor ADTInfo String [Pattern] | Record (Map.Map String Pattern) - deriving(Eq, Show) + deriving(Eq) + +instance Show Pattern where + show pattern = case pattern of + Anything -> + "Anything" + + Literal lit -> + "Literal " <> show lit + Ctor _ name pats -> + "Ctor " <> name <> show pats + + Record fields -> + "Record " <> show fields data Literal = Chr Char @@ -54,10 +69,9 @@ data Literal -- CREATE SIMPLIFIED PATTERNS - simplify :: Slv.AST -> Env -> Slv.Pattern -> Infer Pattern simplify _ _ (Slv.Untyped _ _) = undefined -simplify ast env (Slv.Typed _ _ pattern) = case pattern of +simplify ast env (Slv.Typed (_ :=> t) _ pattern) = case pattern of Slv.PAny -> return Anything @@ -66,7 +80,15 @@ simplify ast env (Slv.Typed _ _ pattern) = case pattern of Slv.PRecord fields -> do fields' <- mapM (simplify ast env) fields - return $ Record fields' + let allFields = case t of + TRecord fieldTypes _ -> + Map.union + fields' + (Map.map (const Anything) fieldTypes) + + _ -> + fields' + return $ Record allFields -- TODO: Add this pattern -- Can.PUnit -> @@ -81,15 +103,24 @@ simplify ast env (Slv.Typed _ _ pattern) = case pattern of Slv.PCon name args -> do args' <- mapM (simplify ast env) args td <- findTypeDeclByConstructorName ast name - let ctors = Slv.unsafeGetADTConstructors (Maybe.fromMaybe undefined td) - return $ Ctor (ADTInfo (length ctors) ctors) name args' + case td of + Nothing -> + -- Most likely a constructor that does not exist, in that case we skip + -- it by returning Anything as an error has already been emitted for + -- this. + return Anything + + Just td' -> do + let ctors = Slv.unsafeGetADTConstructors td' + return $ Ctor (ADTInfo (length ctors) ctors) (canonicalizeCtorName name) args' Slv.PList lis -> do let nil = Ctor (ADTInfo 2 [conCtor, nilCtor]) "__Nil__" [] case Slv.getSpreadPattern lis of - Just _ -> do + Just _ -> buildConsPattern lis + -- buildConsPattern (reverse lis) Nothing -> foldM @@ -100,7 +131,7 @@ simplify ast env (Slv.Typed _ _ pattern) = case pattern of nil lis where - conCtor = Slv.Untyped emptyArea (Slv.Constructor "__Cons__" [Slv.Untyped emptyArea (Slv.TRSingle "a")] tList) + conCtor = Slv.Untyped emptyArea (Slv.Constructor "__Cons__" [Slv.Untyped emptyArea (Slv.TRSingle "a"), Slv.Untyped emptyArea (Slv.TRSingle "a")] tList) nilCtor = Slv.Untyped emptyArea (Slv.Constructor "__Nil__" [] tList) buildConsPattern :: [Slv.Pattern] -> Infer Pattern buildConsPattern patterns = case patterns of @@ -112,6 +143,9 @@ simplify ast env (Slv.Typed _ _ pattern) = case pattern of pats' <- buildConsPattern pats return $ Ctor (ADTInfo 2 [conCtor, nilCtor]) "__Cons__" [pats', pat'] + _ -> + undefined + Slv.PSpread pattern -> simplify ast env pattern @@ -129,20 +163,10 @@ simplify ast env (Slv.Typed _ _ pattern) = case pattern of falseCtor = Slv.Untyped emptyArea (Slv.Constructor "false" [] tBool) return $ Ctor (ADTInfo 2 [trueCtor, falseCtor]) (if bool == "true" then "true" else "false") [] - _ -> - return Anything - - - -{-# NOINLINE nilName #-} -nilName :: String -nilName = "[]" - -- ERROR - data Error = Incomplete [Pattern] | Redundant Int @@ -152,15 +176,13 @@ data Error -- CHECK - check :: Env -> Slv.AST -> Infer () check env ast@Slv.AST { Slv.aexps } = do checkExps ast env aexps --- CHECK DECLS - +-- CHECK Exps checkExps :: Slv.AST -> Env -> [Slv.Exp] -> Infer () checkExps ast env exps = do @@ -173,134 +195,118 @@ checkExps ast env exps = do return () - --- CHECK EXPRESSIONS - - checkExp :: Slv.AST -> Env -> Slv.Exp -> Infer () +checkExp _ _ (Slv.Untyped _ _) = undefined checkExp ast env (Slv.Typed _ area expression) = case expression of Slv.Assignment _ exp -> checkExp ast env exp - Slv.ListConstructor lis -> - foldM - (\_ li -> case li of - Slv.Typed _ _ (Slv.ListItem e) -> - checkExp ast env e - - Slv.Typed _ _ (Slv.ListSpread e) -> - checkExp ast env e - ) - () - lis - - Slv.Where e cases -> do - checkCases ast env area cases - checkExp ast env e - - _ -> - return () - - - -- Can.VarLocal _ -> - -- errors - - -- Can.VarTopLevel _ _ -> - -- errors + Slv.TypedExp exp _ _ -> + checkExp ast env exp - -- Can.VarKernel _ _ -> - -- errors + Slv.App fn arg _ -> do + checkExp ast env fn + checkExp ast env arg - -- Can.VarForeign _ _ _ -> - -- errors + Slv.Abs _ body -> + mapM_ (checkExp ast env) body - -- Can.VarCtor _ _ _ _ _ -> - -- errors + Slv.Do body -> + mapM_ (checkExp ast env) body - -- Can.VarDebug _ _ _ -> - -- errors + Slv.Var _ _ -> + return () - -- Can.VarOperator _ _ _ _ -> - -- errors + Slv.If cond truthy falsy -> do + checkExp ast env cond + checkExp ast env truthy + checkExp ast env falsy - -- Can.Chr _ -> - -- errors + Slv.NameExport _ -> + return () - -- Can.Str _ -> - -- errors + Slv.Placeholder _ exp -> + checkExp ast env exp - -- Can.Int _ -> - -- errors + Slv.Access rec field -> do + checkExp ast env rec + checkExp ast env field - -- Can.Float _ -> - -- errors + Slv.Extern {} -> + return () - -- Can.List entries -> - -- foldr checkExp errors entries + Slv.TypeExport _ -> + return () - -- Can.Negate expr -> - -- checkExp expr errors + Slv.Export exp -> + checkExp ast env exp - -- Can.Binop _ _ _ _ left right -> - -- checkExp left $ - -- checkExp right errors + Slv.TupleConstructor exps -> + mapM_ (checkExp ast env) exps - -- Can.Lambda args body -> - -- foldr checkArg (checkExp body errors) args + Slv.ListConstructor lis -> + foldM + (\_ li -> case li of + Slv.Typed _ _ (Slv.ListItem e) -> + checkExp ast env e - -- Can.Call func args -> - -- checkExp func $ foldr checkExp errors args + Slv.Typed _ _ (Slv.ListSpread e) -> + checkExp ast env e - -- Can.If branches finally -> - -- foldr checkIfBranch (checkExp finally errors) branches + Slv.Untyped _ _ -> + undefined + ) + () + lis - -- Can.Let def body -> - -- checkDef def $ checkExp body errors + Slv.Record fields -> + foldM + (\_ li -> case li of + Slv.Typed _ _ (Slv.Field (_, e)) -> + checkExp ast env e - -- Can.LetRec defs body -> - -- foldr checkDef (checkExp body errors) defs + Slv.Typed _ _ (Slv.FieldSpread e) -> + checkExp ast env e - -- Can.LetDestruct pattern@(A.At reg _) expr body -> - -- checkPatterns reg BadDestruct [pattern] $ - -- checkExp expr $ checkExp body errors + Slv.Untyped _ _ -> + undefined + ) + () + fields - -- Can.Case expr branches -> - -- checkExp expr $ checkCases region branches errors + Slv.Where e cases -> do + checkCases ast env area cases + checkExp ast env e - -- Can.Accessor _ -> - -- errors + Slv.LNum _ -> + return () - -- Can.Access record _ -> - -- checkExp record errors + Slv.LFloat _ -> + return () - -- Can.Update _ record fields -> - -- checkExp record $ Map.foldr checkField errors fields + Slv.LBool _ -> + return () - -- Can.Record fields -> - -- Map.foldr checkExp errors fields + Slv.LStr _ -> + return () - -- Can.Unit -> - -- errors + Slv.LChar _ -> + return () - -- Can.Tuple a b maybeC -> - -- checkExp a $ - -- checkExp b $ - -- case maybeC of - -- Nothing -> - -- errors + Slv.LUnit -> + return () - -- Just c -> - -- checkExp c errors + Slv.JSExp _ -> + return () - -- Can.Shader _ _ -> - -- errors + Slv.TemplateString exps -> + mapM_ (checkExp ast env) exps -- CHECK CASE EXPRESSION - checkCases :: Slv.AST -> Env -> Area -> [Slv.Is] -> Infer () checkCases ast env area cases = do patterns <- foldM (checkCaseBranch ast env) [] cases @@ -308,14 +314,14 @@ checkCases ast env area cases = do checkCaseBranch :: Slv.AST -> Env -> [Slv.Pattern] -> Slv.Is -> Infer [Slv.Pattern] +checkCaseBranch _ _ _ (Slv.Untyped _ _) = undefined checkCaseBranch ast env patterns (Slv.Typed _ _ (Slv.Is pattern exp)) = do checkExp ast env exp return $ pattern : patterns --- -- CHECK PATTERNS - +-- CHECK PATTERNS checkPatterns :: Slv.AST -> Env -> Area -> [Slv.Pattern] -> Infer () checkPatterns ast env area patterns = do @@ -330,7 +336,9 @@ checkPatterns ast env area patterns = do return () badPatterns -> do - pushWarning (CompilationWarning (IncompletePattern (map showPattern $ concat badPatterns)) (Context (envCurrentPath env) area)) + let badPatterns' = map head $ filter (not . null) badPatterns + unless (null badPatterns') $ + pushWarning (CompilationWarning (IncompletePattern (map showPattern badPatterns')) (Context (envCurrentPath env) area)) showPattern :: Pattern -> String @@ -351,7 +359,18 @@ showPattern pattern = case pattern of Ctor _ name args -> if name == "__Cons__" then - "[" <> List.intercalate ", " (List.replicate (getConsArgCount pattern) "_") <> "]" + case getConsArgs pattern of + [] -> + "[]" + + [arg] -> + "[" <> showPattern arg <> "]" + + realArgs -> + if last realArgs == Anything then + "[" <> List.intercalate ", " (map showPattern (init realArgs)) <> ", ..._" <> "]" + else + "[" <> List.intercalate ", " (map showPattern realArgs) <> "]" else if name == "__Nil__" then "[]" else if name `List.elem` [ "(,)" @@ -376,17 +395,19 @@ showPattern pattern = case pattern of "{ " <> List.intercalate ", " (map (\(name, pat) -> name <> ": " <> showPattern pat) (Map.toList fields)) <> " }" -getConsArgCount :: Pattern -> Int -getConsArgCount pattern = case pattern of - Ctor _ "__Cons__" args -> - 1 + getConsArgCount (head args) +getConsArgs :: Pattern -> [Pattern] +getConsArgs pattern = case pattern of + Ctor _ "__Cons__" [tail, arg] -> + arg : getConsArgs tail - _ -> - 0 + Ctor _ "__Nil__" _ -> + [] + arg -> + [arg] --- EXHAUSTIVE PATTERNS +-- EXHAUSTIVE PATTERNS -- INVARIANTS: -- @@ -404,35 +425,36 @@ isExhaustive matrix n = if n == 0 then [] else - let ctors = collectCtors matrix - numSeen = Map.size ctors - in if numSeen == 0 then - let maybeBaseRecord = extractRecordPatterns matrix - in case maybeBaseRecord of - Nothing -> - (:) Anything - <$> isExhaustive (Maybe.mapMaybe specializeRowByAnything matrix) (n - 1) - - Just baseRecord -> - let fieldNames = Map.keys baseRecord - isAltExhaustive fieldName = - isExhaustive - (Maybe.mapMaybe (specializeRowByRecordField fieldName) matrix) - n - in concatMap isAltExhaustive fieldNames - else - let alts@(ADTInfo numAlts ctorList) = snd (Map.findMin ctors) - in if numSeen < numAlts then - (:) - <$> Maybe.mapMaybe (isMissing alts ctors) ctorList - <*> isExhaustive (Maybe.mapMaybe specializeRowByAnything matrix) (n - 1) - else - let isAltExhaustive (Slv.Untyped _ (Slv.Constructor name params _)) = - recoverCtor alts name (length params) <$> + let ctors = collectCtors matrix + numSeen = Map.size ctors + in if numSeen == 0 then + let maybeBaseRecord = extractRecordPatterns matrix + in case maybeBaseRecord of + Nothing -> + (:) Anything + <$> isExhaustive (Maybe.mapMaybe specializeRowByAnything matrix) (n - 1) + + Just baseRecord -> + let fieldNames = Map.keys baseRecord + isAltExhaustive fieldName = isExhaustive - (Maybe.mapMaybe (specializeRowByCtor name (length params)) matrix) - (length params + n - 1) - in concatMap isAltExhaustive ctorList + (Maybe.mapMaybe (specializeRowByRecordField fieldName) matrix) + n + fields' = map (\fieldName -> ((fieldName,) <$>) <$> filter (not . null) (isAltExhaustive fieldName)) fieldNames + in map (map (Record . Map.fromList)) fields' + else + let alts@(ADTInfo numAlts ctorList) = snd (Map.findMin ctors) + in if numSeen < numAlts then + (:) + <$> Maybe.mapMaybe (isMissing alts ctors) ctorList + <*> isExhaustive (Maybe.mapMaybe specializeRowByAnything matrix) (n - 1) + else + let isAltExhaustive (Slv.Untyped _ (Slv.Constructor name params _)) = + recoverCtor alts name (length params) <$> + isExhaustive + (Maybe.mapMaybe (specializeRowByCtor name (length params)) matrix) + (length params + n - 1) + in concatMap isAltExhaustive ctorList isMissing :: ADTInfo -> Map.Map String a -> Slv.Constructor -> Maybe Pattern @@ -458,13 +480,13 @@ recoverCtor union name arity patterns = -- INVARIANT: Produces a list of rows where (forall row. length row == 1) -toNonRedundantRows :: Slv.AST -> Env -> [Slv.Pattern] -> Infer (Either Error [[Pattern]]) +toNonRedundantRows :: Slv.AST -> Env -> [Slv.Pattern] -> Infer (Either () [[Pattern]]) toNonRedundantRows ast env patterns = - toSimplifiedUsefulRows ast env [] [] patterns + toSimplifiedUsefulRows ast env [] [] (reverse patterns) -- INVARIANT: Produces a list of rows where (forall row. length row == 1) -toSimplifiedUsefulRows :: Slv.AST -> Env -> [[Pattern]] -> [Slv.Pattern] -> [Slv.Pattern] -> Infer (Either Error [[Pattern]]) +toSimplifiedUsefulRows :: Slv.AST -> Env -> [[Pattern]] -> [Slv.Pattern] -> [Slv.Pattern] -> Infer (Either () [[Pattern]]) toSimplifiedUsefulRows ast env checkedRows checkedPatterns uncheckedPatterns = case uncheckedPatterns of [] -> @@ -476,12 +498,10 @@ toSimplifiedUsefulRows ast env checkedRows checkedPatterns uncheckedPatterns = if isUseful checkedRows nextRow then toSimplifiedUsefulRows ast env (nextRow : checkedRows) (pattern : checkedPatterns) rest else do - -- pushWarning $ CompilationWarning RedundantPattern (Context (envCurrentPath env) (Slv.getArea pattern)) mapM_ (pushWarning . CompilationWarning RedundantPattern . Context (envCurrentPath env) . Slv.getArea) - (pattern : checkedPatterns) - return $ Left (Redundant (length checkedRows + 1)) - + [pattern] + toSimplifiedUsefulRows ast env (nextRow : checkedRows) (pattern : checkedPatterns) rest -- Check if a new row "vector" is useful given previous rows "matrix" @@ -563,7 +583,7 @@ specializeRowByCtor ctorName arity row = \ should never align in pattern match exhaustiveness checks." [] -> - Just [] + error "Compiler error! Empty matrices should not get specialized." -- INVARIANT: (length row == N) ==> (length result == N-1) @@ -687,7 +707,6 @@ isComplete matrix = -- COLLECT CTORS - collectCtors :: [[Pattern]] -> Map.Map String ADTInfo collectCtors matrix = List.foldl' collectCtorsHelp Map.empty matrix @@ -704,6 +723,7 @@ collectCtorsHelp ctors row = -- COLLECT RECORD FIELDS + extractRecordPatterns :: [[Pattern]] -> Maybe (Map.Map String Pattern) extractRecordPatterns matrix = if containsRecord matrix then @@ -740,15 +760,35 @@ collectRecordFields nameCollection row = nameCollection +findTypeDeclInASTByConstructorName :: Slv.AST -> String -> Maybe Slv.TypeDecl +findTypeDeclInASTByConstructorName Slv.AST { Slv.atypedecls } ctorName = + List.find + (\case + Slv.Untyped _ Slv.ADT { Slv.adtconstructors } -> + any ((== ctorName) . Slv.getConstructorName) adtconstructors + + _ -> + False + ) + atypedecls + + +canonicalizeCtorName :: String -> String +canonicalizeCtorName ctorName = + if "." `List.isInfixOf` ctorName then + tail $ List.dropWhile (/= '.') ctorName + else + ctorName + findTypeDeclByConstructorName :: Rock.MonadFetch Query m => Slv.AST -> String -> m (Maybe Slv.TypeDecl) -findTypeDeclByConstructorName Slv.AST { Slv.atypedecls, Slv.aimports } ctorName = do +findTypeDeclByConstructorName ast@Slv.AST { Slv.aimports } ctorName = do let searchInForeignModule _ = do let (importPath, realCtorName) = if "." `List.isInfixOf` ctorName then let namespace = List.takeWhile (/= '.') ctorName ctorName' = tail $ List.dropWhile (/= '.') ctorName foundImport = - Maybe.fromMaybe (error ("namespace is: " <> namespace)) $ List.find + List.find (\case Slv.Untyped _ (Slv.DefaultImport (Slv.Untyped _ name) _ _) -> name == namespace @@ -756,10 +796,10 @@ findTypeDeclByConstructorName Slv.AST { Slv.atypedecls, Slv.aimports } ctorName _ -> False ) aimports - in (Slv.getImportAbsolutePath foundImport, ctorName') + in (Slv.getImportAbsolutePath <$> foundImport, ctorName') else let foundImport = - Maybe.fromMaybe undefined $ List.find + List.find (\case Slv.Untyped _ (Slv.NamedImport names _ _) -> any ((== ctorName) . Slv.getValue) names @@ -767,17 +807,15 @@ findTypeDeclByConstructorName Slv.AST { Slv.atypedecls, Slv.aimports } ctorName _ -> False ) aimports - in (Slv.getImportAbsolutePath foundImport, ctorName) - Rock.fetch $ ForeignTypeDeclaration importPath realCtorName - let foundTypeDecl = List.find - (\case - Slv.Untyped _ Slv.ADT { Slv.adtconstructors } -> - any ((== ctorName) . Slv.getConstructorName) adtconstructors - - _ -> - False - ) - atypedecls + in (Slv.getImportAbsolutePath <$> foundImport, ctorName) + case importPath of + Nothing -> + return Nothing + + Just importPath' -> do + (ast', _) <- Rock.fetch $ SolvedASTWithEnv importPath' + return $ findTypeDeclInASTByConstructorName ast' realCtorName + let foundTypeDecl = findTypeDeclInASTByConstructorName ast ctorName case foundTypeDecl of Just found -> return $ Just found diff --git a/compiler/main/Run/LanguageServer.hs b/compiler/main/Run/LanguageServer.hs index 00c53af3f..e4b4b865b 100644 --- a/compiler/main/Run/LanguageServer.hs +++ b/compiler/main/Run/LanguageServer.hs @@ -791,13 +791,13 @@ generateDiagnostics invalidatePath state uri fileUpdates = do let path = uriToPath uri (jsWarnings, jsErrors) <- runTypeCheck invalidatePath state TNode path fileUpdates - sendDiagnosticsForWarningsAndErrors jsWarnings jsErrors + -- sendDiagnosticsForWarningsAndErrors jsWarnings jsErrors (llvmWarnings, llvmErrors) <- runTypeCheck invalidatePath state TLLVM path fileUpdates let allWarnings = jsWarnings `List.union` llvmWarnings let allErrors = jsErrors `List.union` llvmErrors - flushDiagnosticsBySource 20 (Just "Madlib") + -- flushDiagnosticsBySource 20 (Just "Madlib") sendDiagnosticsForWarningsAndErrors allWarnings allErrors diff --git a/madlib.cabal b/madlib.cabal index ee3ca49a7..b411609ee 100644 --- a/madlib.cabal +++ b/madlib.cabal @@ -5,7 +5,7 @@ cabal-version: 2.0 -- see: https://github.com/sol/hpack name: madlib -version: 0.16.2 +version: 0.17.0 description: Please see the README on GitHub at homepage: https://github.com/madlib-lang/madlib#readme bug-reports: https://github.com/madlib-lang/madlib/issues diff --git a/package.yaml b/package.yaml index a178a0a8d..c1a24aede 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: madlib -version: 0.16.2 +version: 0.17.0 github: "madlib-lang/madlib" license: BSD3 author: "Arnaud Boeglin, Brekk Bockrath" diff --git a/pkg/package.json b/pkg/package.json index 527994baf..fd4f74acd 100644 --- a/pkg/package.json +++ b/pkg/package.json @@ -1,6 +1,6 @@ { "name": "@madlib-lang/madlib", - "version": "0.16.2", + "version": "0.17.0", "main": "./src/run.js", "bin": { "madlib": "src/run.js" diff --git a/prelude/__internal__/List.mad b/prelude/__internal__/List.mad index 7fadf10ee..97211fa0a 100644 --- a/prelude/__internal__/List.mad +++ b/prelude/__internal__/List.mad @@ -668,10 +668,7 @@ export zip = (as, bs) => where(#[as, bs]) { #[[a, ...aa], [b, ...bb]] => [#[a, b], ...zip(aa, bb)] - #[[a], [b]] => - [#[a, b]] - - #[[], []] => + #[_, _] => [] } diff --git a/prelude/__internal__/Process.mad b/prelude/__internal__/Process.mad index 03d1b0c2c..b8fb8cae6 100644 --- a/prelude/__internal__/Process.mad +++ b/prelude/__internal__/Process.mad @@ -161,6 +161,9 @@ export Argv = where (getArgsFFI()) { String.take(2, exePath) == "./" ? [canonicalizePath(joinPath([getCurrentWorkingDirectory(), exePath])), ...args] : [exePath, ...args] + + [] => + [] }