diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 5d8555cdbd..64a1f3ed14 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -15,6 +15,7 @@ import Data.Functor.Identity (Identity(..)) import Data.Aeson.TH (Options(..), SumEncoding(..), defaultOptions, deriveJSON) import Data.Map qualified as M +import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.List.NonEmpty qualified as NEL import GHC.Generics (Generic) @@ -339,6 +340,8 @@ unwrapTypeDeclaration td = (tydeclIdent td, tydeclType td) -- In this example @double@ is the identifier, @x@ is a binder and @x + x@ is the expression. data ValueDeclarationData a = ValueDeclarationData { valdeclSourceAnn :: !SourceAnn + , valdeclTypeDeclAnn :: !(Maybe SourceAnn) + -- ^ The matching type declaration's annotation , valdeclIdent :: !Ident -- ^ The declared value's name , valdeclName :: !NameKind @@ -351,9 +354,9 @@ getValueDeclaration :: Declaration -> Maybe (ValueDeclarationData [GuardedExpr]) getValueDeclaration (ValueDeclaration d) = Just d getValueDeclaration _ = Nothing -pattern ValueDecl :: SourceAnn -> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration -pattern ValueDecl sann ident name binders expr - = ValueDeclaration (ValueDeclarationData sann ident name binders expr) +pattern ValueDecl :: SourceAnn -> Maybe SourceAnn -> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration +pattern ValueDecl sann tann ident name binders expr + = ValueDeclaration (ValueDeclarationData sann tann ident name binders expr) data DataConstructorDeclaration = DataConstructorDeclaration { dataCtorAnn :: !SourceAnn @@ -405,7 +408,7 @@ data Declaration -- | -- A minimal mutually recursive set of value declarations -- - | BindingGroupDeclaration (NEL.NonEmpty ((SourceAnn, Ident), NameKind, Expr)) + | BindingGroupDeclaration (NEL.NonEmpty ((SourceAnn, Maybe SourceAnn, Ident), NameKind, Expr)) -- | -- A foreign import declaration (name, type) -- @@ -488,9 +491,9 @@ declSourceAnn (TypeSynonymDeclaration sa _ _ _) = sa declSourceAnn (KindDeclaration sa _ _ _) = sa declSourceAnn (RoleDeclaration rd) = rdeclSourceAnn rd declSourceAnn (TypeDeclaration td) = tydeclSourceAnn td -declSourceAnn (ValueDeclaration vd) = valdeclSourceAnn vd +declSourceAnn (ValueDeclaration vd) = fromMaybe (valdeclSourceAnn vd) (valdeclTypeDeclAnn vd) declSourceAnn (BoundValueDeclaration sa _ _) = sa -declSourceAnn (BindingGroupDeclaration ds) = let ((sa, _), _, _) = NEL.head ds in sa +declSourceAnn (BindingGroupDeclaration ds) = let ((sa, ta, _), _, _) = NEL.head ds in fromMaybe sa ta declSourceAnn (ExternDeclaration sa _ _) = sa declSourceAnn (ExternDataDeclaration sa _ _) = sa declSourceAnn (FixityDeclaration sa _) = sa diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 8aa8808a85..5f5afc13cb 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -57,8 +57,8 @@ everywhereOnValues f g h = (f', g', h') where f' :: Declaration -> Declaration f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (fmap f' ds)) - f' (ValueDecl sa name nameKind bs val) = - f (ValueDecl sa name nameKind (fmap h' bs) (fmap (mapGuardedExpr handleGuard g') val)) + f' (ValueDecl sa ta name nameKind bs val) = + f (ValueDecl sa ta name nameKind (fmap h' bs) (fmap (mapGuardedExpr handleGuard g') val)) f' (BoundValueDeclaration sa b expr) = f (BoundValueDeclaration sa (h' b) (g' expr)) f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (fmap (\(name, nameKind, val) -> (name, nameKind, g' val)) ds)) f' (TypeClassDeclaration sa name args implies deps ds) = f (TypeClassDeclaration sa name args implies deps (fmap f' ds)) @@ -131,8 +131,8 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) f' :: Declaration -> m Declaration f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds - f' (ValueDecl sa name nameKind bs val) = - ValueDecl sa name nameKind <$> traverse (h' <=< h) bs <*> traverse (guardedExprM handleGuard (g' <=< g)) val + f' (ValueDecl sa ta name nameKind bs val) = + ValueDecl sa ta name nameKind <$> traverse (h' <=< h) bs <*> traverse (guardedExprM handleGuard (g' <=< g)) val f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (name, nameKind, ) <$> (g val >>= g')) ds f' (TypeClassDeclaration sa name args implies deps ds) = TypeClassDeclaration sa name args implies deps <$> traverse (f' <=< f) ds f' (TypeInstanceDeclaration sa na ch idx name cs className args ds) = TypeInstanceDeclaration sa na ch idx name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds @@ -200,8 +200,8 @@ everywhereOnValuesM f g h = (f', g', h') f' :: Declaration -> m Declaration f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f - f' (ValueDecl sa name nameKind bs val) = - ValueDecl sa name nameKind <$> traverse h' bs <*> traverse (guardedExprM handleGuard g') val >>= f + f' (ValueDecl sa ta name nameKind bs val) = + ValueDecl sa ta name nameKind <$> traverse h' bs <*> traverse (guardedExprM handleGuard g') val >>= f f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (name, nameKind, ) <$> g' val) ds) >>= f f' (BoundValueDeclaration sa b expr) = (BoundValueDeclaration sa <$> h' b <*> g' expr) >>= f f' (TypeClassDeclaration sa name args implies deps ds) = (TypeClassDeclaration sa name args implies deps <$> traverse f' ds) >>= f @@ -461,8 +461,8 @@ everywhereWithContextOnValuesM s0 f g h i j k = (f'' s0, g'' s0, h'' s0, i'' s0, f'' s = uncurry f' <=< f s f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f'' s) ds - f' s (ValueDecl sa name nameKind bs val) = - ValueDecl sa name nameKind <$> traverse (h'' s) bs <*> traverse (guardedExprM (k' s) (g'' s)) val + f' s (ValueDecl sa ta name nameKind bs val) = + ValueDecl sa ta name nameKind <$> traverse (h'' s) bs <*> traverse (guardedExprM (k' s) (g'' s)) val f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (thirdM (g'' s)) ds f' s (TypeClassDeclaration sa name args implies deps ds) = TypeClassDeclaration sa name args implies deps <$> traverse (f'' s) ds f' s (TypeInstanceDeclaration sa na ch idx name cs className args ds) = TypeInstanceDeclaration sa na ch idx name cs className args <$> traverseTypeInstanceBody (traverse (f'' s)) ds @@ -561,12 +561,12 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) f' s (DataBindingGroupDeclaration ds) = let s' = S.union s (S.fromList (map ToplevelIdent (mapMaybe getDeclIdent (NEL.toList ds)))) in foldMap (f'' s') ds - f' s (ValueDecl _ name _ bs val) = + f' s (ValueDecl _ _ name _ bs val) = let s' = S.insert (ToplevelIdent name) s s'' = S.union s' (S.fromList (concatMap localBinderNames bs)) in foldMap (h'' s') bs <> foldMap (l' s'') val f' s (BindingGroupDeclaration ds) = - let s' = S.union s (S.fromList (NEL.toList (fmap (\((_, name), _, _) -> ToplevelIdent name) ds))) + let s' = S.union s (S.fromList (NEL.toList (fmap (\((_, _, name), _, _) -> ToplevelIdent name) ds))) in foldMap (\(_, _, val) -> g'' s' val) ds f' s (TypeClassDeclaration _ _ _ _ _ ds) = foldMap (f'' s) ds f' s (TypeInstanceDeclaration _ _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldMap (f'' s) ds diff --git a/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs index b70754f897..50e98a6407 100644 --- a/src/Language/PureScript/CST/Convert.hs +++ b/src/Language/PureScript/CST/Convert.hs @@ -621,7 +621,7 @@ convertValueBindingFields fileName ann (ValueBindingFields a bs c) = do let bs' = convertBinder fileName <$> bs cs' = convertGuarded fileName c - AST.ValueDeclaration $ AST.ValueDeclarationData ann (ident $ nameValue a) Env.Public bs' cs' + AST.ValueDeclaration $ AST.ValueDeclarationData ann Nothing (ident $ nameValue a) Env.Public bs' cs' convertImportDecl :: String diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 5b0f821be4..9298f3cb33 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -6,7 +6,7 @@ import Protolude (ordNub, orEmpty) import Control.Arrow (second) import Data.Function (on) -import Data.Maybe (mapMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Tuple (swap) import Data.List.NonEmpty qualified as NEL import Data.Map qualified as M @@ -76,10 +76,15 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = in NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields declToCoreFn (A.DataBindingGroupDeclaration ds) = concatMap declToCoreFn ds - declToCoreFn (A.ValueDecl (ss, com) name _ _ [A.MkUnguarded e]) = - [NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)] - declToCoreFn (A.BindingGroupDeclaration ds) = - [Rec . NEL.toList $ fmap (\(((ss, com), name), _, e) -> ((ssA ss, name), exprToCoreFn ss com Nothing e)) ds] + declToCoreFn (A.ValueDecl sa ta name _ _ [A.MkUnguarded e]) = + let (ss, com) = fromMaybe sa ta + in [NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)] + declToCoreFn (A.BindingGroupDeclaration ds) = do + let + toBinding ((sa, ta, name), _, e) = + let (ss, com) = fromMaybe sa ta + in ((ssA ss, name), exprToCoreFn ss com Nothing e) + [Rec . NEL.toList $ toBinding <$> ds] declToCoreFn _ = [] -- Desugars expressions from AST to CoreFn representation. diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index b3b15e7b4f..e89deadce1 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -156,12 +156,14 @@ basicDeclaration :: P.SourceAnn -> Text -> DeclarationInfo -> Maybe Intermediate basicDeclaration sa title = Just . Right . mkDeclaration sa title convertDeclaration :: P.Declaration -> Text -> Maybe IntermediateDeclaration -convertDeclaration (P.ValueDecl sa _ _ _ [P.MkUnguarded (P.TypedValue _ _ ty)]) title = - basicDeclaration sa title (ValueDeclaration (ty $> ())) -convertDeclaration (P.ValueDecl sa _ _ _ _) title = +convertDeclaration (P.ValueDecl sa ta _ _ _ [P.MkUnguarded (P.TypedValue _ _ ty)]) title = + let ann = fromMaybe sa ta in + basicDeclaration ann title (ValueDeclaration (ty $> ())) +convertDeclaration (P.ValueDecl sa ta _ _ _ _) title = -- If no explicit type declaration was provided, insert a wildcard, so that -- the actual type will be added during type checking. - basicDeclaration sa title (ValueDeclaration (P.TypeWildcard () P.UnnamedWildcard)) + let ann = fromMaybe sa ta in + basicDeclaration ann title (ValueDeclaration (P.TypeWildcard () P.UnnamedWildcard)) convertDeclaration (P.ExternDeclaration sa _ ty) title = basicDeclaration sa title (ValueDeclaration (ty $> ())) convertDeclaration (P.DataDeclaration sa dtype _ args ctors) title = diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index ea49fd6a55..fa4dadd05d 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -71,7 +71,7 @@ extractSpans -> [(IdeNamespaced, P.SourceSpan)] -- ^ Declarations and their source locations extractSpans d = case d of - P.ValueDecl (ss, _) i _ _ _ -> + P.ValueDecl (ss, _) _ i _ _ _ -> [(IdeNamespaced IdeNSValue (P.runIdent i), ss)] P.TypeSynonymDeclaration (ss, _) name _ _ -> [(IdeNamespaced IdeNSType (P.runProperName name), ss)] diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index 61083eee2e..eaaa6a471a 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -42,14 +42,14 @@ createTemporaryModule exec st val = supportImport = (fst (psciInteractivePrint st), P.Implicit, Just (P.ModuleName "$Support")) eval = P.Var internalSpan (P.Qualified (P.ByModuleName (P.ModuleName "$Support")) (snd (psciInteractivePrint st))) mainValue = P.App eval (P.Var internalSpan (P.Qualified P.ByNullSourcePos (P.Ident "it"))) - itDecl = P.ValueDecl (internalSpan, []) (P.Ident "it") P.Public [] [P.MkUnguarded val] + itDecl = P.ValueDecl (internalSpan, []) Nothing (P.Ident "it") P.Public [] [P.MkUnguarded val] typeDecl = P.TypeDeclaration (P.TypeDeclarationData (internalSpan, []) (P.Ident "$main") (P.srcTypeApp (P.srcTypeConstructor (P.Qualified (P.ByModuleName (P.ModuleName "$Effect")) (P.ProperName "Effect"))) P.srcTypeWildcard)) - mainDecl = P.ValueDecl (internalSpan, []) (P.Ident "$main") P.Public [] [P.MkUnguarded mainValue] + mainDecl = P.ValueDecl (internalSpan, []) Nothing (P.Ident "$main") P.Public [] [P.MkUnguarded mainValue] decls = if exec then [itDecl, typeDecl, mainDecl] else [itDecl] in P.Module internalSpan diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 95f4029cdf..32cb0c23e7 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -256,7 +256,7 @@ lintUnused (Module modSS _ mn modDecls exports) = -- (non-recursively, recursively) bound idents in decl declIdents :: Declaration -> (S.Set (SourceSpan, Ident), S.Set (SourceSpan, Ident)) - declIdents (ValueDecl (ss,_) ident _ _ _) = (S.empty, S.singleton (ss, ident)) + declIdents (ValueDecl (ss,_) _ ident _ _ _) = (S.empty, S.singleton (ss, ident)) declIdents (BoundValueDeclaration _ binders _) = (S.fromList $ binderNamesWithSpans binders, S.empty) declIdents _ = (S.empty, S.empty) @@ -274,7 +274,7 @@ lintUnused (Module modSS _ mn modDecls exports) = removeAndWarn letNamesRec errs'' -- let f x = e -- check the x in e (but not the f) - underDecl (ValueDecl _ _ _ binders gexprs) = + underDecl (ValueDecl _ _ _ _ binders gexprs) = let bindNewNames = S.fromList (concatMap binderNamesWithSpans binders) allExprs = concatMap unguard gexprs in diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 85b6638fdc..eff4115bdf 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -130,12 +130,12 @@ prettyPrintDeclaration :: Int -> Declaration -> Box prettyPrintDeclaration d _ | d < 0 = ellipsis prettyPrintDeclaration d (TypeDeclaration td) = text (T.unpack (showIdent (tydeclIdent td)) ++ " :: ") <> typeAsBox d (tydeclType td) -prettyPrintDeclaration d (ValueDecl _ ident _ [] [GuardedExpr [] val]) = +prettyPrintDeclaration d (ValueDecl _ _ ident _ [] [GuardedExpr [] val]) = text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d - 1) val prettyPrintDeclaration d (BindingGroupDeclaration ds) = vsep 1 left (NEL.toList (fmap (prettyPrintDeclaration (d - 1) . toDecl) ds)) where - toDecl ((sa, nm), t, e) = ValueDecl sa nm t [] [GuardedExpr [] e] + toDecl ((sa, ta, nm), t, e) = ValueDecl sa ta nm t [] [GuardedExpr [] e] prettyPrintDeclaration _ _ = internalError "Invalid argument to prettyPrintDeclaration" prettyPrintCaseAlternative :: Int -> CaseAlternative -> Box diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index d2f9aebf2b..59660cc09c 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -160,8 +160,8 @@ flattenBindingGroups = concatMap go where go (DataBindingGroupDeclaration ds) = NEL.toList ds go (BindingGroupDeclaration ds) = - NEL.toList $ fmap (\((sa, ident), nameKind, val) -> - ValueDecl sa ident nameKind [] [MkUnguarded val]) ds + NEL.toList $ fmap (\((sa, ta, ident), nameKind, val) -> + ValueDecl sa ta ident nameKind [] [MkUnguarded val]) ds go other = [other] usedIdents :: ModuleName -> ValueDeclarationData Expr -> [Ident] @@ -253,12 +253,12 @@ toBindingGroup moduleName (CyclicSCC ds') = do valueVerts :: [(ValueDeclarationData Expr, Ident, [Ident])] valueVerts = fmap (\d -> (d, valdeclIdent d, usedImmediateIdents moduleName (mkDeclaration d) `intersect` idents)) ds' - toBinding :: SCC (ValueDeclarationData Expr) -> m ((SourceAnn, Ident), NameKind, Expr) + toBinding :: SCC (ValueDeclarationData Expr) -> m ((SourceAnn, Maybe SourceAnn, Ident), NameKind, Expr) toBinding (AcyclicSCC d) = return $ fromValueDecl d toBinding (CyclicSCC ds) = throwError $ foldMap cycleError ds cycleError :: ValueDeclarationData Expr -> MultipleErrors - cycleError (ValueDeclarationData (ss, _) n _ _ _) = errorMessage' ss $ CycleInDeclaration n + cycleError (ValueDeclarationData (ss, _) _ n _ _ _) = errorMessage' ss $ CycleInDeclaration n toDataBindingGroup :: MonadError MultipleErrors m @@ -300,6 +300,6 @@ isTypeSynonym _ = Nothing mkDeclaration :: ValueDeclarationData Expr -> Declaration mkDeclaration = ValueDeclaration . fmap (pure . MkUnguarded) -fromValueDecl :: ValueDeclarationData Expr -> ((SourceAnn, Ident), NameKind, Expr) -fromValueDecl (ValueDeclarationData sa ident nameKind [] val) = ((sa, ident), nameKind, val) +fromValueDecl :: ValueDeclarationData Expr -> ((SourceAnn, Maybe SourceAnn, Ident), NameKind, Expr) +fromValueDecl (ValueDeclarationData sa ta ident nameKind [] val) = ((sa, ta, ident), nameKind, val) fromValueDecl ValueDeclarationData{} = internalError "Binders should have been desugared" diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index bcae767715..30712ef626 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -65,7 +65,7 @@ desugarGuardedExprs ss (Case scrut alternatives) (scrut', scrut_decls) <- unzip <$> forM scrut (\e -> do scrut_id <- freshIdent' pure ( Var ss (Qualified ByNullSourcePos scrut_id) - , ValueDecl (ss, []) scrut_id Private [] [MkUnguarded e] + , ValueDecl (ss, []) Nothing scrut_id Private [] [MkUnguarded e] ) ) Let FromLet scrut_decls <$> desugarGuardedExprs ss (Case scrut' alternatives) @@ -232,7 +232,7 @@ desugarGuardedExprs ss (Case scrut alternatives) = alt_fail n = [CaseAlternative (replicate n NullBinder) [MkUnguarded goto_rem_case]] pure $ Let FromLet [ - ValueDecl (ss, []) rem_case_id Private [] + ValueDecl (ss, []) Nothing rem_case_id Private [] [MkUnguarded (Abs (VarBinder ss unused_binder) desugared)] ] (mk_body alt_fail) @@ -329,10 +329,10 @@ desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGro desugarRest :: [Declaration] -> m [Declaration] desugarRest (TypeInstanceDeclaration sa na cd idx name constraints className tys ds : rest) = (:) <$> (TypeInstanceDeclaration sa na cd idx name constraints className tys <$> traverseTypeInstanceBody desugarCases ds) <*> desugarRest rest - desugarRest (ValueDecl sa name nameKind bs result : rest) = + desugarRest (ValueDecl sa ta name nameKind bs result : rest) = let (_, f, _) = everywhereOnValuesTopDownM return go return f' = mapM (\(GuardedExpr gs e) -> GuardedExpr gs <$> f e) - in (:) <$> (ValueDecl sa name nameKind bs <$> f' result) <*> desugarRest rest + in (:) <$> (ValueDecl sa ta name nameKind bs <$> f' result) <*> desugarRest rest where go (Let w ds val') = Let w <$> desugarCases ds <*> pure val' go other = return other @@ -344,11 +344,11 @@ inSameGroup (ValueDeclaration vd1) (ValueDeclaration vd2) = valdeclIdent vd1 == inSameGroup _ _ = False toDecls :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] -toDecls [ValueDecl sa@(ss, _) ident nameKind bs [MkUnguarded val]] | all isIrrefutable bs = do +toDecls [ValueDecl sa@(ss, _) ta ident nameKind bs [MkUnguarded val]] | all isIrrefutable bs = do args <- mapM fromVarBinder bs let body = foldr (Abs . VarBinder ss) val args guardWith (errorMessage' ss (OverlappingArgNames (Just ident))) $ length (ordNub args) == length args - return [ValueDecl sa ident nameKind [] [MkUnguarded body]] + return [ValueDecl sa ta ident nameKind [] [MkUnguarded body]] where fromVarBinder :: Binder -> m Ident fromVarBinder NullBinder = freshIdent' @@ -356,7 +356,7 @@ toDecls [ValueDecl sa@(ss, _) ident nameKind bs [MkUnguarded val]] | all isIrref fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b fromVarBinder (TypedBinder _ b) = fromVarBinder b fromVarBinder _ = internalError "fromVarBinder: Invalid argument" -toDecls ds@(ValueDecl (ss, _) ident _ bs (result : _) : _) = do +toDecls ds@(ValueDecl (ss, _) _ ident _ bs (result : _) : _) = do let tuples = map toTuple ds isGuarded (MkUnguarded _) = False @@ -371,7 +371,7 @@ toDecls ds@(ValueDecl (ss, _) ident _ bs (result : _) : _) = do toDecls ds = return ds toTuple :: Declaration -> ([Binder], [GuardedExpr]) -toTuple (ValueDecl _ _ _ bs result) = (bs, result) +toTuple (ValueDecl _ _ _ _ bs result) = (bs, result) toTuple _ = internalError "Not a value declaration" makeCaseDeclaration :: forall m. (MonadSupply m) => SourceSpan -> Ident -> [([Binder], [GuardedExpr])] -> m Declaration @@ -385,7 +385,7 @@ makeCaseDeclaration ss ident alternatives = do binders = [ CaseAlternative bs result | (bs, result) <- alternatives ] let value = foldr (Abs . uncurry VarBinder) (Case vars binders) args - return $ ValueDecl (ss, []) ident Public [] [MkUnguarded value] + return $ ValueDecl (ss, []) Nothing ident Public [] [MkUnguarded value] where -- We will construct a table of potential names. -- VarBinders will become Just _ which is a potential name. diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index 8542a5a790..52de709869 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -74,7 +74,7 @@ desugarDo d = go _ _ [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet go pos m (DoNotationLet ds : rest) = do let checkBind :: Declaration -> m () - checkBind (ValueDecl (ss, _) i@(Ident name) _ _ _) + checkBind (ValueDecl (ss, _) _ i@(Ident name) _ _ _) | name `elem` [ C.S_bind, C.S_discard ] = throwError . errorMessage' ss $ CannotUseBindWithDo i checkBind _ = pure () mapM_ checkBind ds diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 2202633667..aa491bbed6 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -332,7 +332,7 @@ renameInModule imports (Module modSS coms mn decls exps) = . binderNamesWithSpans letBoundVariable :: Declaration -> Maybe (Ident, SourceSpan) - letBoundVariable = fmap (valdeclIdent &&& (fst . valdeclSourceAnn)) . getValueDeclaration + letBoundVariable = fmap (valdeclIdent &&& (\d -> fst $ fromMaybe (valdeclSourceAnn d) (valdeclTypeDeclAnn d))) . getValueDeclaration declarationsToMap :: [Declaration] -> M.Map Ident SourcePos declarationsToMap = foldl goDTM M.empty diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index 88b93b899c..d5eff347c9 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -59,7 +59,7 @@ desugarDecl d = rethrowWithPosition (declSourceSpan d) $ fn d then Abs (VarBinder nullSourceSpan val) <$> wrapLambda (buildUpdates valExpr) ps else wrapLambda (buildLet val . buildUpdates valExpr) ps where - buildLet val = Let FromLet [ValueDecl (declSourceSpan d, []) val Public [] [MkUnguarded obj]] + buildLet val = Let FromLet [ValueDecl (declSourceSpan d, []) Nothing val Public [] [MkUnguarded obj]] -- recursively build up the nested `ObjectUpdate` expressions buildUpdates :: Expr -> PathTree Expr -> Expr diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index a5bfa59b90..c9677087ab 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -225,7 +225,7 @@ desugarDecl mn exps = go dictTy = foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictTypeName) className)) tys constrainedTy = quantify (foldr srcConstrainedType dictTy deps) in - return $ ValueDecl sa name' Private [] [MkUnguarded (TypedValue True dict constrainedTy)] + return $ ValueDecl sa Nothing name' Private [] [MkUnguarded (TypedValue True dict constrainedTy)] return (expRef name' className tys, [d, dictDecl]) go other = return (Nothing, [other]) @@ -300,7 +300,7 @@ typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration (TypeDeclarati dictObjIdent = Ident "v" ctor = ConstructorBinder ss (coerceProperName . dictTypeName <$> className) [VarBinder ss dictObjIdent] acsr = Accessor (mkString $ runIdent ident) (Var ss (Qualified ByNullSourcePos dictObjIdent)) - in ValueDecl sa ident Private [] + in ValueDecl sa Nothing ident Private [] [MkUnguarded ( TypedValue False (Abs (VarBinder ss dictIdent) (Case [Var ss $ Qualified ByNullSourcePos dictIdent] [CaseAlternative [ctor] [MkUnguarded acsr]])) $ moveQuantifiersToFront (quantify (srcConstrainedType (srcConstraint className [] (map (srcTypeVar . fst) args) Nothing) ty)) @@ -353,13 +353,13 @@ typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls = dictTy = foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictTypeName) className)) tys constrainedTy = quantify (foldr srcConstrainedType dictTy deps) dict = App (Constructor ss (fmap (coerceProperName . dictTypeName) className)) props - result = ValueDecl sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)] + result = ValueDecl sa Nothing name Private [] [MkUnguarded (TypedValue True dict constrainedTy)] return result where memberToValue :: [(Ident, SourceType)] -> Declaration -> Desugar m Expr - memberToValue tys' (ValueDecl (ss', _) ident _ [] [MkUnguarded val]) = do + memberToValue tys' (ValueDecl (ss', _) _ ident _ [] [MkUnguarded val]) = do _ <- maybe (throwError . errorMessage' ss' $ ExtraneousClassMember ident className) return $ lookup ident tys' return val memberToValue _ _ = internalError "Invalid declaration in type instance definition" diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 3b4c019521..4cd8ee643e 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -79,13 +79,13 @@ deriveGenericRep ss mn tyCon tyConArgs = let rep = toRepTy reps inst | null reps = -- If there are no cases, spin - [ ValueDecl (ss', []) (Ident "to") Public [] $ unguarded $ + [ ValueDecl (ss', []) Nothing (Ident "to") Public [] $ unguarded $ lamCase x [ CaseAlternative [NullBinder] (unguarded (App (Var ss Libs.I_to) (Var ss' (Qualified ByNullSourcePos x)))) ] - , ValueDecl (ss', []) (Ident "from") Public [] $ unguarded $ + , ValueDecl (ss', []) Nothing (Ident "from") Public [] $ unguarded $ lamCase x [ CaseAlternative [NullBinder] @@ -93,9 +93,9 @@ deriveGenericRep ss mn tyCon tyConArgs = ] ] | otherwise = - [ ValueDecl (ss', []) (Ident "to") Public [] $ unguarded $ + [ ValueDecl (ss', []) Nothing (Ident "to") Public [] $ unguarded $ lamCase x (zipWith ($) (map underBinder (sumBinders (length dctors))) to) - , ValueDecl (ss', []) (Ident "from") Public [] $ unguarded $ + , ValueDecl (ss', []) Nothing (Ident "from") Public [] $ unguarded $ lamCase x (zipWith ($) (map underExpr (sumExprs (length dctors))) from) ] diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index ef00748d67..4cd389332a 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -11,8 +11,8 @@ import Prelude import Control.Monad (unless) import Control.Monad.Error.Class (MonadError(..)) -import Language.PureScript.AST (Declaration(..), ErrorMessageHint(..), Expr(..), GuardedExpr(..), KindSignatureFor(..), pattern MkUnguarded, Module(..), RoleDeclarationData(..), TypeDeclarationData(..), TypeInstanceBody(..), pattern ValueDecl, declSourceSpan, everywhereOnValuesTopDownM) -import Language.PureScript.Names (Ident, coerceProperName) +import Language.PureScript.AST (Declaration(..), ErrorMessageHint(..), Expr(..), GuardedExpr(..), KindSignatureFor(..), pattern MkUnguarded, Module(..), RoleDeclarationData(..), TypeDeclarationData(..), TypeInstanceBody(..), pattern ValueDecl, declSourceSpan, everywhereOnValuesTopDownM, SourceAnn) +import Language.PureScript.Names (coerceProperName) import Language.PureScript.Environment (DataDeclType(..), NameKind) import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage', rethrow) @@ -32,21 +32,21 @@ desugarTypeDeclarationsModule (Module modSS coms name ds exps) = where desugarTypeDeclarations :: [Declaration] -> m [Declaration] - desugarTypeDeclarations (TypeDeclaration (TypeDeclarationData sa name' ty) : d : rest) = do - (_, nameKind, val) <- fromValueDeclaration d - desugarTypeDeclarations (ValueDecl sa name' nameKind [] [MkUnguarded (TypedValue True val ty)] : rest) + desugarTypeDeclarations (TypeDeclaration (TypeDeclarationData ta name' ty) : d : rest) = do + (sa, nameKind, val) <- fromValueDeclaration d + desugarTypeDeclarations (ValueDecl sa (Just ta) name' nameKind [] [MkUnguarded (TypedValue True val ty)] : rest) where - fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr) - fromValueDeclaration (ValueDecl _ name'' nameKind [] [MkUnguarded val]) - | name' == name'' = return (name'', nameKind, val) + fromValueDeclaration :: Declaration -> m (SourceAnn, NameKind, Expr) + fromValueDeclaration (ValueDecl sa _ name'' nameKind [] [MkUnguarded val]) + | name' == name'' = return (sa, nameKind, val) fromValueDeclaration d' = throwError . errorMessage' (declSourceSpan d') $ OrphanTypeDeclaration name' desugarTypeDeclarations [TypeDeclaration (TypeDeclarationData (ss, _) name' _)] = throwError . errorMessage' ss $ OrphanTypeDeclaration name' - desugarTypeDeclarations (ValueDecl sa name' nameKind bs val : rest) = do + desugarTypeDeclarations (ValueDecl sa ta name' nameKind bs val : rest) = do let (_, f, _) = everywhereOnValuesTopDownM return go return f' = mapM (\(GuardedExpr g e) -> GuardedExpr g <$> f e) - (:) <$> (ValueDecl sa name' nameKind bs <$> f' val) + (:) <$> (ValueDecl sa ta name' nameKind bs <$> f' val) <*> desugarTypeDeclarations rest where go (Let w ds' val') = Let w <$> desugarTypeDeclarations ds' <*> pure val' diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 3f5043ad24..8972ee3704 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -349,31 +349,32 @@ typeCheckAll moduleName = traverse go return d go TypeDeclaration{} = internalError "Type declarations should have been removed before typeCheckAlld" - go (ValueDecl sa@(ss, _) name nameKind [] [MkUnguarded val]) = do + go (ValueDecl sa ta name nameKind [] [MkUnguarded val]) = do env <- getEnv let declHint = if isPlainIdent name then addHint (ErrorInValueDeclaration name) else id - warnAndRethrow (declHint . addHint (positionedError ss)) $ do - val' <- checkExhaustiveExpr ss env moduleName val + (errorSpan, _) = fromMaybe sa ta + warnAndRethrow (declHint . addHint (positionedError errorSpan)) $ do + val' <- checkExhaustiveExpr errorSpan env moduleName val valueIsNotDefined moduleName name - typesOf NonRecursiveBindingGroup moduleName [((sa, name), val')] >>= \case + typesOf NonRecursiveBindingGroup moduleName [((sa, ta, name), val')] >>= \case [(_, (val'', ty))] -> do addValue moduleName name ty nameKind - return $ ValueDecl sa name nameKind [] [MkUnguarded val''] + return $ ValueDecl sa ta name nameKind [] [MkUnguarded val''] _ -> internalError "typesOf did not return a singleton" go ValueDeclaration{} = internalError "Binders were not desugared" go BoundValueDeclaration{} = internalError "BoundValueDeclaration should be desugared" go (BindingGroupDeclaration vals) = do env <- getEnv - let sss = fmap (\(((ss, _), _), _, _) -> ss) vals - warnAndRethrow (addHint (ErrorInBindingGroup (fmap (\((_, ident), _, _) -> ident) vals)) . addHint (PositionedError sss)) $ do - for_ vals $ \((_, ident), _, _) -> valueIsNotDefined moduleName ident - vals' <- NEL.toList <$> traverse (\(sai@((ss, _), _), nk, expr) -> (sai, nk,) <$> checkExhaustiveExpr ss env moduleName expr) vals + let sss = fmap (\((sa, ta, _), _, _) -> fst $ fromMaybe sa ta) vals + warnAndRethrow (addHint (ErrorInBindingGroup (fmap (\((_, _, ident), _, _) -> ident) vals)) . addHint (PositionedError sss)) $ do + for_ vals $ \((_, _, ident), _, _) -> valueIsNotDefined moduleName ident + vals' <- NEL.toList <$> traverse (\(sai@((ss, _), _, _), nk, expr) -> (sai, nk,) <$> checkExhaustiveExpr ss env moduleName expr) vals tys <- typesOf RecursiveBindingGroup moduleName $ fmap (\(sai, _, ty) -> (sai, ty)) vals' vals'' <- forM [ (sai, val, nameKind, ty) - | (sai@(_, name), nameKind, _) <- vals' - , ((_, name'), (val, ty)) <- tys + | (sai@(_, _, name), nameKind, _) <- vals' + , ((_, _, name'), (val, ty)) <- tys , name == name' - ] $ \(sai@(_, name), val, nameKind, ty) -> do + ] $ \(sai@(_, _, name), val, nameKind, ty) -> do addValue moduleName name ty nameKind return (sai, nameKind, val) return . BindingGroupDeclaration $ NEL.fromList vals'' diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index ab532057e8..7c4426f777 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -87,8 +87,8 @@ typesOf :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => BindingGroupType -> ModuleName - -> [((SourceAnn, Ident), Expr)] - -> m [((SourceAnn, Ident), (Expr, SourceType))] + -> [((SourceAnn, Maybe SourceAnn, Ident), Expr)] + -> m [((SourceAnn, Maybe SourceAnn, Ident), (Expr, SourceType))] typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do (tys, wInfer) <- capturingSubstitution tidyUp $ do (SplitBindingGroup untyped typed dict, w) <- withoutWarnings $ typeDictionaryForBindingGroup (Just moduleName) vals @@ -96,7 +96,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do ds2 <- forM untyped $ \e -> withoutWarnings $ typeForBindingGroupElement e dict return (map (False, ) ds1 ++ map (True, ) ds2, w) - inferred <- forM tys $ \(shouldGeneralize, ((sai@((ss, _), ident), (val, ty)), _)) -> do + inferred <- forM tys $ \(shouldGeneralize, ((sai@((ss, _), _, ident), (val, ty)), _)) -> do -- Replace type class dictionary placeholders with actual dictionaries (val', unsolved) <- replaceTypeClassDictionaries shouldGeneralize val -- Generalize and constrain the type @@ -229,9 +229,9 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do -- -- This structure breaks down a binding group into typed and untyped parts. data SplitBindingGroup = SplitBindingGroup - { _splitBindingGroupUntyped :: [((SourceAnn, Ident), (Expr, SourceType))] + { _splitBindingGroupUntyped :: [((SourceAnn, Maybe SourceAnn, Ident), (Expr, SourceType))] -- ^ The untyped expressions - , _splitBindingGroupTyped :: [((SourceAnn, Ident), (Expr, [(Text, SourceType)], SourceType, Bool))] + , _splitBindingGroupTyped :: [((SourceAnn, Maybe SourceAnn, Ident), (Expr, [(Text, SourceType)], SourceType, Bool))] -- ^ The typed expressions, along with their type annotations , _splitBindingGroupNames :: M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility) -- ^ A map containing all expressions and their assigned types (which might be @@ -247,7 +247,7 @@ data SplitBindingGroup = SplitBindingGroup typeDictionaryForBindingGroup :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Maybe ModuleName - -> [((SourceAnn, Ident), Expr)] + -> [((SourceAnn, Maybe SourceAnn, Ident), Expr)] -> m SplitBindingGroup typeDictionaryForBindingGroup moduleName vals = do -- Filter the typed and untyped declarations and make a map of names to typed declarations. @@ -266,7 +266,7 @@ typeDictionaryForBindingGroup moduleName vals = do -- Create the dictionary of all name/type pairs, which will be added to the -- environment during type checking let dict = M.fromList [ (Qualified (maybe (BySourcePos $ spanStart ss) ByModuleName moduleName) ident, (ty, Private, Undefined)) - | (((ss, _), ident), ty) <- typedDict <> untypedDict + | (((ss, _), _, ident), ty) <- typedDict <> untypedDict ] return (SplitBindingGroup untyped' typed' dict) where @@ -284,11 +284,11 @@ typeDictionaryForBindingGroup moduleName vals = do checkTypedBindingGroupElement :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName - -> ((SourceAnn, Ident), (Expr, [(Text, SourceType)], SourceType, Bool)) + -> ((SourceAnn, Maybe SourceAnn, Ident), (Expr, [(Text, SourceType)], SourceType, Bool)) -- ^ The identifier we are trying to define, along with the expression and its type annotation -> M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility) -- ^ Names brought into scope in this binding group - -> m ((SourceAnn, Ident), (Expr, SourceType)) + -> m ((SourceAnn, Maybe SourceAnn, Ident), (Expr, SourceType)) checkTypedBindingGroupElement mn (ident, (val, args, ty, checkType)) dict = do -- We replace type synonyms _after_ kind-checking, since we don't want type -- synonym expansion to bring type variables into scope. See #2542. @@ -302,12 +302,12 @@ checkTypedBindingGroupElement mn (ident, (val, args, ty, checkType)) dict = do -- | Infer a type for a value in a binding group which lacks an annotation. typeForBindingGroupElement :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => ((SourceAnn, Ident), (Expr, SourceType)) + => ((SourceAnn, Maybe SourceAnn, Ident), (Expr, SourceType)) -- ^ The identifier we are trying to define, along with the expression and its assigned type -- (at this point, this should be a unification variable) -> M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility) -- ^ Names brought into scope in this binding group - -> m ((SourceAnn, Ident), (Expr, SourceType)) + -> m ((SourceAnn, Maybe SourceAnn, Ident), (Expr, SourceType)) typeForBindingGroupElement (ident, (val, ty)) dict = do -- Infer the type with the new names in scope TypedValue' _ val' ty' <- bindNames dict $ infer val @@ -542,9 +542,10 @@ inferLetBinding -> (Expr -> m TypedValue') -> m ([Declaration], TypedValue') inferLetBinding seen [] ret j = (seen, ) <$> withBindingGroupVisible (j ret) -inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded (TypedValue checkType val ty)] : rest) ret j = do +inferLetBinding seen (ValueDecl sa@(ss, _) ta ident nameKind [] [MkUnguarded (TypedValue checkType val ty)] : rest) ret j = do + let (errorSpan, _) = fromMaybe sa ta moduleName <- unsafeCheckCurrentModule - TypedValue' _ val' ty'' <- warnAndRethrowWithPositionTC ss $ do + TypedValue' _ val' ty'' <- warnAndRethrowWithPositionTC errorSpan $ do ((args, elabTy), kind) <- kindOfWithScopedVars ty checkTypeKind ty kind let dict = M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (elabTy, nameKind, Undefined) @@ -553,21 +554,22 @@ inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded (Typed then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return (TypedValue' checkType val elabTy) bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (ty'', nameKind, Defined)) - $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded (TypedValue checkType val' ty'')]]) rest ret j -inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded val] : rest) ret j = do + $ inferLetBinding (seen ++ [ValueDecl sa ta ident nameKind [] [MkUnguarded (TypedValue checkType val' ty'')]]) rest ret j +inferLetBinding seen (ValueDecl sa@(ss, _) ta ident nameKind [] [MkUnguarded val] : rest) ret j = do + let (errorSpan, _) = fromMaybe sa ta valTy <- freshTypeWithKind kindType - TypedValue' _ val' valTy' <- warnAndRethrowWithPositionTC ss $ do + TypedValue' _ val' valTy' <- warnAndRethrowWithPositionTC errorSpan $ do let dict = M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy, nameKind, Undefined) bindNames dict $ infer val - warnAndRethrowWithPositionTC ss $ unifyTypes valTy valTy' + warnAndRethrowWithPositionTC errorSpan $ unifyTypes valTy valTy' bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy', nameKind, Defined)) - $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded val']]) rest ret j + $ inferLetBinding (seen ++ [ValueDecl sa ta ident nameKind [] [MkUnguarded val']]) rest ret j inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do moduleName <- unsafeCheckCurrentModule SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing . NEL.toList $ fmap (\(i, _, v) -> (i, v)) ds ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict - let ds' = NEL.fromList [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2'] + let ds' = NEL.fromList [((sa, ta, cm), Private, val') | ((sa, ta, cm), (val', _)) <- ds1' ++ ds2'] bindNames dict $ do makeBindingGroupVisible inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index f7de445c0e..94d4957ee0 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -19,7 +19,7 @@ ann2 = (span2, []) typeAnnotation1, value1, synonym1, class1, class2, data1, data2, valueFixity, typeFixity, foreign1, foreign2, member1 :: P.Declaration typeAnnotation1 = P.TypeDeclaration (P.TypeDeclarationData ann1 (P.Ident "value1") P.srcREmpty) -value1 = P.ValueDecl ann1 (P.Ident "value1") P.Public [] [] +value1 = P.ValueDecl ann1 Nothing (P.Ident "value1") P.Public [] [] synonym1 = P.TypeSynonymDeclaration ann1 (P.ProperName "Synonym1") [] P.srcREmpty class1 = P.TypeClassDeclaration ann1 (P.ProperName "Class1") [] [] [] [] class2 = P.TypeClassDeclaration ann1 (P.ProperName "Class2") [] [] [] [member1]