diff options
Diffstat (limited to 'src/Language')
27 files changed, 320 insertions, 201 deletions
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 4de31e2..93f8d87 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -481,6 +481,15 @@ pattern ValueDecl :: SourceAnn -> Ident -> NameKind -> [Binder] -> [GuardedExpr] pattern ValueDecl sann ident name binders expr = ValueDeclaration (ValueDeclarationData sann ident name binders expr) +data DataConstructorDeclaration = DataConstructorDeclaration + { dataCtorAnn :: !SourceAnn + , dataCtorName :: !(ProperName 'ConstructorName) + , dataCtorFields :: ![(Ident, SourceType)] + } deriving (Show, Eq) + +traverseDataCtorFields :: Monad m => ([(Ident, SourceType)] -> m [(Ident, SourceType)]) -> DataConstructorDeclaration -> m DataConstructorDeclaration +traverseDataCtorFields f DataConstructorDeclaration{..} = DataConstructorDeclaration dataCtorAnn dataCtorName <$> f dataCtorFields + -- | -- The data type of declarations -- @@ -488,7 +497,7 @@ data Declaration -- | -- A data type declaration (data or newtype, name, arguments, data constructors) -- - = DataDeclaration SourceAnn DataDeclType (ProperName 'TypeName) [(Text, Maybe SourceKind)] [(ProperName 'ConstructorName, [(Ident, SourceType)])] + = DataDeclaration SourceAnn DataDeclType (ProperName 'TypeName) [(Text, Maybe SourceKind)] [DataConstructorDeclaration] -- | -- A minimal mutually recursive set of data type declarations -- @@ -753,6 +762,12 @@ data Expr -- | App Expr Expr -- | + -- Hint that an expression is unused. + -- This is used to ignore type class dictionaries that are necessarily empty. + -- The inner expression lets us solve subgoals before eliminating the whole expression. + -- The code gen will render this as `undefined`, regardless of what the inner expression is. + | Unused Expr + -- | -- Variable -- | Var SourceSpan (Qualified Ident) diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs index f24b1dc..9cf015e 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -47,7 +47,7 @@ exportedDeclarations (Module _ _ mn decls exps) = go decls filterDataConstructors :: Maybe [DeclarationRef] -> Declaration -> Declaration filterDataConstructors exps (DataDeclaration sa dType tyName tyArgs dctors) = DataDeclaration sa dType tyName tyArgs $ - filter (isDctorExported tyName exps . fst) dctors + filter (isDctorExported tyName exps . dataCtorName) dctors filterDataConstructors _ other = other -- | diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 5367925..70543f8 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -72,6 +72,7 @@ everywhereOnValues f g h = (f', g', h') g' (ObjectUpdateNested obj vs) = g (ObjectUpdateNested (g' obj) (fmap g' vs)) g' (Abs binder v) = g (Abs (h' binder) (g' v)) g' (App v1 v2) = g (App (g' v1) (g' v2)) + g' (Unused v) = g (Unused (g' v)) g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3)) g' (Case vs alts) = g (Case (fmap g' vs) (fmap handleCaseAlternative alts)) g' (TypedValue check v ty) = g (TypedValue check (g' v) ty) @@ -146,6 +147,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) g' (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> (g obj >>= g') <*> traverse (g' <=< g) vs g' (Abs binder v) = Abs <$> (h binder >>= h') <*> (g v >>= g') g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g') + g' (Unused v) = Unused <$> (g v >>= g') g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g') g' (Case vs alts) = Case <$> traverse (g' <=< g) vs <*> traverse handleCaseAlternative alts g' (TypedValue check v ty) = TypedValue check <$> (g v >>= g') <*> pure ty @@ -215,6 +217,7 @@ everywhereOnValuesM f g h = (f', g', h') g' (ObjectUpdateNested obj vs) = (ObjectUpdateNested <$> g' obj <*> traverse g' vs) >>= g g' (Abs binder v) = (Abs <$> h' binder <*> g' v) >>= g g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g + g' (Unused v) = (Unused <$> g' v) >>= g g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g g' (Case vs alts) = (Case <$> traverse g' vs <*> traverse handleCaseAlternative alts) >>= g g' (TypedValue check v ty) = (TypedValue check <$> g' v <*> pure ty) >>= g @@ -287,6 +290,7 @@ everythingOnValues (<>.) f g h i j = (f', g', h', i', j') g' v@(ObjectUpdateNested obj vs) = foldl (<>.) (g v <>. g' obj) (fmap g' vs) g' v@(Abs b v1) = g v <>. h' b <>. g' v1 g' v@(App v1 v2) = g v <>. g' v1 <>. g' v2 + g' v@(Unused v1) = g v <>. g' v1 g' v@(IfThenElse v1 v2 v3) = g v <>. g' v1 <>. g' v2 <>. g' v3 g' v@(Case vs alts) = foldl (<>.) (foldl (<>.) (g v) (fmap g' vs)) (fmap i' alts) g' v@(TypedValue _ v1 _) = g v <>. g' v1 @@ -368,6 +372,7 @@ everythingWithContextOnValues s0 r0 (<>.) f g h i j = (f'' s0, g'' s0, h'' s0, i g' s (ObjectUpdateNested obj vs) = foldl (<>.) (g'' s obj) (fmap (g'' s) vs) g' s (Abs binder v1) = h'' s binder <>. g'' s v1 g' s (App v1 v2) = g'' s v1 <>. g'' s v2 + g' s (Unused v) = g'' s v g' s (IfThenElse v1 v2 v3) = g'' s v1 <>. g'' s v2 <>. g'' s v3 g' s (Case vs alts) = foldl (<>.) (foldl (<>.) r0 (fmap (g'' s) vs)) (fmap (i'' s) alts) g' s (TypedValue _ v1 _) = g'' s v1 @@ -453,6 +458,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j g' s (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> g'' s obj <*> traverse (g'' s) vs g' s (Abs binder v) = Abs <$> h' s binder <*> g'' s v g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2 + g' s (Unused v) = Unused <$> g'' s v g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3 g' s (Case vs alts) = Case <$> traverse (g'' s) vs <*> traverse (i'' s) alts g' s (TypedValue check v ty) = TypedValue check <$> g'' s v <*> pure ty @@ -548,6 +554,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) let s' = S.union (S.fromList (localBinderNames b)) s in h'' s b <> g'' s' v1 g' s (App v1 v2) = g'' s v1 <> g'' s v2 + g' s (Unused v) = g'' s v g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3 g' s (Case vs alts) = foldMap (g'' s) vs <> foldMap (i'' s) alts g' s (TypedValue _ v1 _) = g'' s v1 @@ -629,7 +636,7 @@ accumTypes ) accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty) where - forDecls (DataDeclaration _ _ _ _ dctors) = mconcat (concatMap (fmap (f . snd) . snd) dctors) + forDecls (DataDeclaration _ _ _ _ dctors) = mconcat (concatMap (fmap (f . snd) . dataCtorFields) dctors) forDecls (ExternDeclaration _ _ ty) = f ty forDecls (TypeClassDeclaration _ _ _ implies _ _) = mconcat (concatMap (fmap f . constraintArgs) implies) forDecls (TypeInstanceDeclaration _ _ _ _ cs _ tys _) = mconcat (concatMap (fmap f . constraintArgs) cs) <> mconcat (fmap f tys) @@ -655,7 +662,7 @@ accumKinds f = everythingOnValues mappend forDecls forValues (const mempty) (con where forDecls (DataDeclaration _ _ _ args dctors) = foldMap (foldMap f . snd) args <> - foldMap (foldMap (forTypes . snd) . snd) dctors + foldMap (foldMap (forTypes . snd) . dataCtorFields) dctors forDecls (TypeClassDeclaration _ _ args implies _ _) = foldMap (foldMap f . snd) args <> foldMap (foldMap forTypes . constraintArgs) implies diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 24abfb9..2fd4165 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -28,9 +28,9 @@ import Data.Aeson ((.=)) import Data.Array ((!)) import Data.Char (chr, digitToInt) import Data.Foldable (fold) -import Data.Generics (GenericM, everything, everywhere, gmapMo, mkMp, mkQ, mkT) +import Data.Generics (GenericM, everything, everythingWithContext, everywhere, gmapMo, mkMp, mkQ, mkT) import Data.Graph -import Data.List (stripPrefix) +import Data.List (stripPrefix, (\\)) import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import Data.Version (showVersion) import qualified Data.Aeson as A @@ -91,9 +91,14 @@ guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory f guessModuleType "foreign.js" = pure Foreign guessModuleType name = throwError $ UnsupportedModulePath name --- | A piece of code is identified by its module and its name. These keys are used to label vertices --- in the dependency graph. -type Key = (ModuleIdentifier, String) +data Visibility + = Public + | Internal + deriving (Show, Eq, Ord) + +-- | A piece of code is identified by its module, its name, and whether it is an internal variable +-- or a public member. These keys are used to label vertices in the dependency graph. +type Key = (ModuleIdentifier, String, Visibility) -- | An export is either a "regular export", which exports a name from the regular module we are in, -- or a reexport of a declaration in the corresponding foreign module. @@ -115,7 +120,7 @@ data ExportType -- into the output during codegen. data ModuleElement = Require JSStatement String (Either String ModuleIdentifier) - | Member JSStatement Bool String JSExpression [Key] + | Member JSStatement Visibility String JSExpression [Key] | ExportsList [(ExportType, String, JSExpression, [Key])] | Other JSStatement | Skip JSStatement @@ -133,10 +138,10 @@ instance A.ToJSON ModuleElement where , "name" .= name , "targetPath" .= targetPath ] - (Member _ public name _ dependsOn) -> + (Member _ visibility name _ dependsOn) -> A.object [ "type" .= A.String "Member" , "name" .= name - , "visibility" .= A.String (if public then "Public" else "Internal") + , "visibility" .= show visibility , "dependsOn" .= map keyToJSON dependsOn ] (ExportsList exports) -> @@ -154,9 +159,10 @@ instance A.ToJSON ModuleElement where where - keyToJSON (mid, member) = - A.object [ "module" .= mid - , "member" .= member + keyToJSON (mid, member, visibility) = + A.object [ "module" .= mid + , "member" .= member + , "visibility" .= show visibility ] exportToJSON (RegularExport sourceName, name, _, dependsOn) = @@ -275,24 +281,33 @@ withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es) expand (ty, nm, n1, _) = (ty, nm, n1, ordNub (dependencies modulePath n1)) expandDeps other = other - dependencies :: ModuleIdentifier -> JSExpression -> [(ModuleIdentifier, String)] - dependencies m = everything (++) (mkQ [] toReference) + dependencies :: ModuleIdentifier -> JSExpression -> [Key] + dependencies m = everythingWithContext boundNames (++) (mkQ (const [] &&& id) toReference) where - toReference :: JSExpression -> [(ModuleIdentifier, String)] - toReference (JSMemberDot mn _ nm) + toReference :: JSExpression -> [String] -> ([Key], [String]) + toReference (JSMemberDot mn _ nm) bn | JSIdentifier _ mn' <- mn , JSIdentifier _ nm' <- nm , Just mid <- lookup mn' imports - = [(mid, nm')] - toReference (JSMemberSquare mn _ nm _) + = ([(mid, nm', Public)], bn) + toReference (JSMemberSquare mn _ nm _) bn | JSIdentifier _ mn' <- mn , Just nm' <- fromStringLiteral nm , Just mid <- lookup mn' imports - = [(mid, nm')] - toReference (JSIdentifier _ nm) - | nm `elem` boundNames - = [(m, nm)] - toReference _ = [] + = ([(mid, nm', Public)], bn) + toReference (JSIdentifier _ nm) bn + | nm `elem` bn + -- ^ only add a dependency if this name is still in the list of names + -- bound to the module level (i.e., hasn't been shadowed by a function + -- parameter) + = ([(m, nm, Internal)], bn) + toReference (JSFunctionExpression _ _ _ params _ _) bn + = ([], bn \\ (mapMaybe unIdent $ commaList params)) + toReference _ bn = ([], bn) + + unIdent :: JSIdent -> Maybe String + unIdent (JSIdentName _ name) = Just name + unIdent _ = Nothing -- String literals include the quote chars fromStringLiteral :: JSExpression -> Maybe String @@ -350,8 +365,8 @@ toModule mids mid filename top | Just (importName, importPath) <- matchRequire mids mid stmt = pure (Require stmt importName importPath) toModuleElement stmt - | Just (exported, name, decl) <- matchMember stmt - = pure (Member stmt exported name decl []) + | Just (visibility, name, decl) <- matchMember stmt + = pure (Member stmt visibility name decl []) toModuleElement stmt | Just props <- matchExportsAssignment stmt = ExportsList <$> traverse toExport (trailingCommaList props) @@ -393,7 +408,7 @@ getExportedIdentifiers mname top go stmt | Just props <- matchExportsAssignment stmt = traverse toIdent (trailingCommaList props) - | Just (True, name, _) <- matchMember stmt + | Just (Public, name, _) <- matchMember stmt = pure [name] | otherwise = pure [] @@ -425,18 +440,18 @@ matchRequire mids mid stmt = Nothing -- Matches JS member declarations. -matchMember :: JSStatement -> Maybe (Bool, String, JSExpression) +matchMember :: JSStatement -> Maybe (Visibility, String, JSExpression) matchMember stmt -- var foo = expr; | JSVariable _ jsInit _ <- stmt , [JSVarInitExpression var varInit] <- commaList jsInit , JSIdentifier _ name <- var , JSVarInit _ decl <- varInit - = Just (False, name, decl) + = Just (Internal, name, decl) -- exports.foo = expr; exports["foo"] = expr; | JSAssignStatement e (JSAssign _) decl _ <- stmt , Just name <- accessor e - = Just (True, name, decl) + = Just (Public, name, decl) | otherwise = Nothing where @@ -484,26 +499,20 @@ compile modules entryPoints = filteredModules where -- | Create a set of vertices for a module element. -- - -- Some special cases worth commenting on: - -- - -- 1) Regular exports which simply export their own name do not count as dependencies. - -- Regular exports which rename and reexport an operator do count, however. - -- - -- 2) Require statements don't contribute towards dependencies, since they effectively get - -- inlined wherever they are used inside other module elements. + -- Require statements don't contribute towards dependencies, since they effectively get + -- inlined wherever they are used inside other module elements. toVertices :: ModuleIdentifier -> ModuleElement -> [(ModuleElement, Key, [Key])] - toVertices p m@(Member _ _ nm _ deps) = [(m, (p, nm), deps)] - toVertices p m@(ExportsList exps) = mapMaybe toVertex exps + toVertices p m@(Member _ visibility nm _ deps) = [(m, (p, nm, visibility), deps)] + toVertices p m@(ExportsList exps) = map toVertex exps where - toVertex (ForeignReexport, nm, _, ks) = Just (m, (p, nm), ks) - toVertex (RegularExport nm, nm1, _, ks) | nm /= nm1 = Just (m, (p, nm1), ks) - toVertex _ = Nothing + toVertex (ForeignReexport, nm, _, ks) = (m, (p, nm, Public), ks) + toVertex (RegularExport _, nm, _, ks) = (m, (p, nm, Public), ks) toVertices _ _ = [] -- | The set of vertices whose connected components we are interested in keeping. entryPointVertices :: [Vertex] entryPointVertices = catMaybes $ do - (_, k@(mid, _), _) <- verts + (_, k@(mid, _, Public), _) <- verts guard $ mid `elem` entryPoints return (vertexFor k) @@ -516,7 +525,7 @@ compile modules entryPoints = filteredModules moduleReferenceMap = M.fromAscListWith mappend $ map (vertToModule &&& vertToModuleRefs) $ S.toList reachableSet where vertToModuleRefs v = foldMap (S.singleton . vertToModule) $ graph ! v - vertToModule v = m where (_, (m, _), _) = vertexToNode v + vertToModule v = m where (_, (m, _, _), _) = vertexToNode v filteredModules :: [Module] filteredModules = map filterUsed modules @@ -539,11 +548,11 @@ compile modules entryPoints = filteredModules -- | Filter out the exports for members which aren't used. filterExports :: ModuleElement -> ModuleElement - filterExports (ExportsList exps) = ExportsList (filter (\(_, nm, _, _) -> isKeyUsed (mid, nm)) exps) + filterExports (ExportsList exps) = ExportsList (filter (\(_, nm, _, _) -> isKeyUsed (mid, nm, Public)) exps) filterExports me = me isDeclUsed :: ModuleElement -> Bool - isDeclUsed (Member _ _ nm _ _) = isKeyUsed (mid, nm) + isDeclUsed (Member _ visibility nm _ _) = isKeyUsed (mid, nm, visibility) isDeclUsed (Require _ _ (Right midRef)) = midRef `S.member` modulesReferenced isDeclUsed _ = True diff --git a/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs index 80e8cc4..6f25050 100644 --- a/src/Language/PureScript/CST/Convert.hs +++ b/src/Language/PureScript/CST/Convert.hs @@ -446,18 +446,21 @@ convertDeclaration :: String -> Declaration a -> [AST.Declaration] convertDeclaration fileName decl = case decl of DeclData _ (DataHead _ a vars) bd -> do let - ctr (DataCtor _ x ys) = (nameValue x, zip ctrFields $ convertType fileName <$> ys) - ctrs = case bd of - Nothing -> [] - Just (_, cs) -> ctr <$> toList cs - pure $ AST.DataDeclaration ann Env.Data (nameValue a) (goTypeVar <$> vars) ctrs + ctrs :: SourceToken -> DataCtor a -> [(SourceToken, DataCtor a)] -> [AST.DataConstructorDeclaration] + ctrs st (DataCtor _ name fields) tl + = AST.DataConstructorDeclaration (sourceAnnCommented fileName st (nameTok name)) (nameValue name) (zip ctrFields $ convertType fileName <$> fields) + : (case tl of + [] -> [] + (st', ctor) : tl' -> ctrs st' ctor tl' + ) + pure $ AST.DataDeclaration ann Env.Data (nameValue a) (goTypeVar <$> vars) (maybe [] (\(st, Separated hd tl) -> ctrs st hd tl) bd) DeclType _ (DataHead _ a vars) _ bd -> pure $ AST.TypeSynonymDeclaration ann (nameValue a) (goTypeVar <$> vars) (convertType fileName bd) - DeclNewtype _ (DataHead _ a vars) _ x ys -> do - let ctrs = [(nameValue x, [(head ctrFields, convertType fileName ys)])] + DeclNewtype _ (DataHead _ a vars) st x ys -> do + let ctrs = [AST.DataConstructorDeclaration (sourceAnnCommented fileName st (snd $ declRange decl)) (nameValue x) [(head ctrFields, convertType fileName ys)]] pure $ AST.DataDeclaration ann Env.Newtype (nameValue a) (goTypeVar <$> vars) ctrs DeclClass _ (ClassHead _ sup name vars fdeps) bd -> do let diff --git a/src/Language/PureScript/CST/Layout.hs b/src/Language/PureScript/CST/Layout.hs index 2785e06..39b38fb 100644 --- a/src/Language/PureScript/CST/Layout.hs +++ b/src/Language/PureScript/CST/Layout.hs @@ -238,9 +238,10 @@ insertLayout src@(SourceToken tokAnn tok) nextPos stack = _ -> state & insertDefault where - equalsP _ LytWhere = True - equalsP _ LytLet = True - equalsP _ _ = False + equalsP _ LytWhere = True + equalsP _ LytLet = True + equalsP _ LytLetStmt = True + equalsP _ _ = False -- Guards need masking because of commas. TokPipe -> @@ -249,6 +250,8 @@ insertLayout src@(SourceToken tokAnn tok) nextPos stack = state' & pushStack tokPos LytCaseGuard & insertToken src state'@((_, LytLet) : _, _) -> state' & pushStack tokPos LytDeclGuard & insertToken src + state'@((_, LytLetStmt) : _, _) -> + state' & pushStack tokPos LytDeclGuard & insertToken src state'@((_, LytWhere) : _, _) -> state' & pushStack tokPos LytDeclGuard & insertToken src _ -> diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index b404558..3ab44b0 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -28,6 +28,7 @@ import Language.PureScript.Sugar.TypeClasses (typeClassMemberName, superClassDic import Language.PureScript.Types import Language.PureScript.PSString (mkString) import qualified Language.PureScript.AST as A +import qualified Language.PureScript.Constants as C -- | Desugars a module from AST to CoreFn representation. moduleToCoreFn :: Environment -> A.Module -> Module Ann @@ -52,14 +53,16 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = -- | Desugars member declarations from AST to CoreFn representation. declToCoreFn :: A.Declaration -> [Bind Ann] - declToCoreFn (A.DataDeclaration (ss, com) Newtype _ _ [(ctor, _)]) = - [NonRec (ssA ss) (properToIdent ctor) $ + declToCoreFn (A.DataDeclaration (ss, com) Newtype _ _ [ctor]) = + [NonRec (ssA ss) (properToIdent $ A.dataCtorName ctor) $ Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var (ssAnn ss) $ Qualified Nothing (Ident "x"))] declToCoreFn d@(A.DataDeclaration _ Newtype _ _ _) = error $ "Found newtype with multiple constructors: " ++ show d declToCoreFn (A.DataDeclaration (ss, com) Data tyName _ ctors) = - flip fmap ctors $ \(ctor, _) -> - let (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor) + flip fmap ctors $ \ctorDecl -> + let + ctor = A.dataCtorName ctorDecl + (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor) in NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields declToCoreFn (A.DataBindingGroupDeclaration ds) = concatMap declToCoreFn ds @@ -85,6 +88,8 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = internalError "Abs with Binder argument was not desugared before exprToCoreFn mn" exprToCoreFn ss com ty (A.App v1 v2) = App (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing v1) (exprToCoreFn ss [] Nothing v2) + exprToCoreFn ss com ty (A.Unused _) = + Var (ss, com, ty, Nothing) (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined)) exprToCoreFn _ com ty (A.Var ss ident) = Var (ss, com, ty, getValueMeta ident) ident exprToCoreFn ss com ty (A.IfThenElse v1 v2 v3) = diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs index fcf49fc..2b0f077 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs @@ -4,6 +4,7 @@ module Language.PureScript.CoreImp.Optimizer.TCO (tco) where import Prelude.Compat import Data.Text (Text) +import qualified Language.PureScript.Constants as C import Language.PureScript.CoreImp.AST import Language.PureScript.AST.SourcePos (SourceSpan) import Safe (headDef, tailSafe) @@ -120,6 +121,9 @@ tco = everywhere convert where markDone ss = Assignment ss (Var ss tcoDone) (BooleanLiteral ss True) collectArgs :: [[AST]] -> AST -> [[AST]] + collectArgs acc (App _ fn []) = + -- count 0-argument applications as single-argument so we get the correct number of args + collectArgs ([Var Nothing C.undefined] : acc) fn collectArgs acc (App _ fn args') = collectArgs (args' : acc) fn collectArgs acc _ = acc diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 1ab7188..60e2ddb 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -128,9 +128,9 @@ convertDeclaration (P.DataDeclaration sa dtype _ args ctors) title = where info = DataDeclaration dtype (fmap (fmap (fmap ($> ()))) args) children = map convertCtor ctors - convertCtor :: (P.ProperName 'P.ConstructorName, [(P.Ident, P.SourceType)]) -> ChildDeclaration - convertCtor (ctor', tys) = - ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor (fmap (($> ()) . snd) tys)) + convertCtor :: P.DataConstructorDeclaration -> ChildDeclaration + convertCtor P.DataConstructorDeclaration{..} = + ChildDeclaration (P.runProperName dataCtorName) (convertComments $ snd dataCtorAnn) Nothing (ChildDataConstructor (fmap (($> ()) . snd) dataCtorFields)) convertDeclaration (P.ExternDataDeclaration sa _ kind') title = basicDeclaration sa title (ExternDataDeclaration (kind' $> ())) convertDeclaration (P.ExternKindDeclaration sa _) title = diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index 6fc9253..3fabafa 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -348,7 +348,7 @@ partial = primClass "Partial" $ T.unlines , "a partial function with a bad input will usually cause an error to be" , "thrown, although it is not safe to assume that this will happen in all" , "cases. For more information, see" - , "[the Partial type class guide](https://github.com/purescript/documentation/blob/master/guides/The-Partial-type-class.md)." + , "[purescript-partial](https://pursuit.purescript.org/packages/purescript-partial/)." ] kindBoolean :: Declaration diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 3e9505a..f6bea0e 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -69,6 +69,8 @@ data TypeClassData = TypeClassData -- typeClassArguments and typeClassDependencies. , typeClassCoveringSets :: S.Set (S.Set Int) -- ^ A sets of arguments that can be used to infer all other arguments. + , typeClassIsEmpty :: Bool + -- ^ Whether or not dictionaries for this type class are necessarily empty. } deriving (Show, Generic) instance NFData TypeClassData @@ -125,8 +127,9 @@ makeTypeClassData -> [(Ident, SourceType)] -> [SourceConstraint] -> [FunctionalDependency] + -> Bool -> TypeClassData -makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs coveringSets +makeTypeClassData args m s deps tcIsEmpty = TypeClassData args m s deps determinedArgs coveringSets tcIsEmpty where argumentIndicies = [0 .. length args - 1] @@ -486,7 +489,7 @@ primTypeErrorTypes = primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primClasses = M.fromList - [ (primName "Partial", (makeTypeClassData [] [] [] [])) + [ (primName "Partial", (makeTypeClassData [] [] [] [] True)) ] -- | This contains all of the type classes from all Prim modules. @@ -511,7 +514,7 @@ primRowClasses = [ FunctionalDependency [0, 1] [2] , FunctionalDependency [1, 2] [0] , FunctionalDependency [2, 0] [1] - ]) + ] True) -- class Nub (original :: # Type) (nubbed :: # Type) | i -> o , (primSubName C.moduleRow "Nub", makeTypeClassData @@ -519,13 +522,13 @@ primRowClasses = , ("nubbed", Just (kindRow kindType)) ] [] [] [ FunctionalDependency [0] [1] - ]) + ] True) -- class Lacks (label :: Symbol) (row :: # Type) , (primSubName C.moduleRow "Lacks", makeTypeClassData [ ("label", Just kindSymbol) , ("row", Just (kindRow kindType)) - ] [] [] []) + ] [] [] [] True) -- class RowCons (label :: Symbol) (a :: Type) (tail :: # Type) (row :: # Type) | label tail a -> row, label row -> tail a , (primSubName C.moduleRow "Cons", makeTypeClassData @@ -536,7 +539,7 @@ primRowClasses = ] [] [] [ FunctionalDependency [0, 1, 2] [3] , FunctionalDependency [0, 3] [1, 2] - ]) + ] True) ] primRowListClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData @@ -548,7 +551,7 @@ primRowListClasses = , ("list", Just kindRowList) ] [] [] [ FunctionalDependency [0] [1] - ]) + ] True) ] primSymbolClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData @@ -563,7 +566,7 @@ primSymbolClasses = [ FunctionalDependency [0, 1] [2] , FunctionalDependency [1, 2] [0] , FunctionalDependency [2, 0] [1] - ]) + ] True) -- class Compare (left :: Symbol) (right :: Symbol) (ordering :: Ordering) | left right -> ordering , (primSubName C.moduleSymbol "Compare", makeTypeClassData @@ -572,7 +575,7 @@ primSymbolClasses = , ("ordering", Just kindOrdering) ] [] [] [ FunctionalDependency [0, 1] [2] - ]) + ] True) -- class Cons (head :: Symbol) (tail :: Symbol) (symbol :: Symbol) | head tail -> symbol, symbol -> head tail , (primSubName C.moduleSymbol "Cons", makeTypeClassData @@ -582,7 +585,7 @@ primSymbolClasses = ] [] [] [ FunctionalDependency [0, 1] [2] , FunctionalDependency [2] [0, 1] - ]) + ] True) ] primTypeErrorClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData @@ -590,11 +593,11 @@ primTypeErrorClasses = M.fromList -- class Fail (message :: Symbol) [ (primSubName C.typeError "Fail", makeTypeClassData - [("message", Just kindDoc)] [] [] []) + [("message", Just kindDoc)] [] [] [] True) -- class Warn (message :: Symbol) , (primSubName C.typeError "Warn", makeTypeClassData - [("message", Just kindDoc)] [] [] []) + [("message", Just kindDoc)] [] [] [] True) ] -- | Finds information about data constructors from the current environment. diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 08bee19..cb4f460 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -616,26 +616,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , markCodeBox $ indent $ typeAsBox prettyDepth ty ] renderSimpleErrorMessage (TypesDoNotUnify u1 u2) - = let (sorted1, sorted2) = sortRows u1 u2 - - sortRows :: Ord a => Type a -> Type a -> (Type a, Type a) - sortRows r1@RCons{} r2@RCons{} = sortRows' (rowToList r1) (rowToList r2) - sortRows t1 t2 = (t1, t2) - - -- Put the common labels last - sortRows' :: Ord a => ([RowListItem a], Type a) -> ([RowListItem a], Type a) -> (Type a, Type a) - sortRows' (s1, r1) (s2, r2) = - let elem' s (RowListItem _ name ty) = any (\(RowListItem _ name' ty') -> name == name' && eqType ty ty') s - sort' = sortBy (comparing $ \(RowListItem _ name ty) -> (name, ty)) - (common1, unique1) = partition (elem' s2) s1 - (common2, unique2) = partition (elem' s1) s2 - in ( rowFromList (sort' unique1 ++ sort' common1, r1) - , rowFromList (sort' unique2 ++ sort' common2, r2) - ) + = let (row1Box, row2Box) = printRows u1 u2 + in paras [ line "Could not match type" - , markCodeBox $ indent $ typeAsBox prettyDepth sorted1 + , row1Box , line "with type" - , markCodeBox $ indent $ typeAsBox prettyDepth sorted2 + , row2Box ] renderSimpleErrorMessage (KindsDoNotUnify k1 k2) = @@ -1062,6 +1048,16 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl ] renderHint :: ErrorMessageHint -> Box.Box -> Box.Box + renderHint (ErrorUnifyingTypes t1@RCons{} t2@RCons{}) detail = + let (row1Box, row2Box) = printRows t1 t2 + in paras [ detail + , Box.hsep 1 Box.top [ line "while trying to match type" + , row1Box + ] + , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "with type" + , row2Box + ] + ] renderHint (ErrorUnifyingTypes t1 t2) detail = paras [ detail , Box.hsep 1 Box.top [ line "while trying to match type" @@ -1190,6 +1186,27 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , detail ] + printRow :: (Int -> Type a -> Box.Box) -> Type a -> Box.Box + printRow f t = markCodeBox $ indent $ f prettyDepth t + + -- If both rows are not empty, print them as diffs + printRows :: Type a -> Type a -> (Box.Box, Box.Box) + printRows r1@RCons{} r2@RCons{} = let + (sorted1, sorted2) = filterRows (rowToList r1) (rowToList r2) + in (printRow typeDiffAsBox sorted1, printRow typeDiffAsBox sorted2) + printRows r1 r2 = (printRow typeAsBox r1, printRow typeAsBox r2) + + -- Keep the unique labels only + filterRows :: ([RowListItem a], Type a) -> ([RowListItem a], Type a) -> (Type a, Type a) + filterRows (s1, r1) (s2, r2) = + let sort' = sortBy (comparing $ \(RowListItem _ name ty) -> (name, ty)) + notElem' s (RowListItem _ name ty) = all (\(RowListItem _ name' ty') -> name /= name' || not (eqType ty ty')) s + unique1 = filter (notElem' s2) s1 + unique2 = filter (notElem' s1) s2 + in ( rowFromList (sort' unique1, r1) + , rowFromList (sort' unique2, r2) + ) + renderContext :: Context -> [Box.Box] renderContext [] = [] renderContext ctx = diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 0953ea2..31d24b2 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -132,6 +132,7 @@ data ExternsDeclaration = , edClassMembers :: [(Ident, SourceType)] , edClassConstraints :: [SourceConstraint] , edFunctionalDependencies :: [FunctionalDependency] + , edIsEmpty :: Bool } -- | An instance declaration | EDInstance @@ -157,7 +158,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) } applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) } applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) } - applyDecl env (EDClass pn args members cs deps) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps) (typeClasses env) } + applyDecl env (EDClass pn args members cs deps tcIsEmpty) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps tcIsEmpty) (typeClasses env) } applyDecl env (EDKind pn) = env { kinds = S.insert (qual pn) (kinds env) } applyDecl env (EDInstance className ident tys cs ch idx) = env { typeClassDictionaries = @@ -227,7 +228,7 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..} , Just (_, synTy) <- Qualified (Just mn) (coerceProperName className) `M.lookup` typeSynonyms env = [ EDType (coerceProperName className) kind TypeSynonym , EDTypeSynonym (coerceProperName className) typeClassArguments synTy - , EDClass className typeClassArguments typeClassMembers typeClassSuperclasses typeClassDependencies + , EDClass className typeClassArguments typeClassMembers typeClassSuperclasses typeClassDependencies typeClassIsEmpty ] toExternsDeclaration (TypeInstanceRef _ ident) = [ EDInstance tcdClassName ident tcdInstanceTypes tcdDependencies tcdChain tcdIndex diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index bda3212..726478a 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -87,8 +87,7 @@ extractSpans d = case d of P.TypeClassDeclaration (ss, _) name _ _ _ members -> (IdeNamespaced IdeNSType (P.runProperName name), ss) : concatMap extractSpans' members P.DataDeclaration (ss, _) _ name _ ctors -> - (IdeNamespaced IdeNSType (P.runProperName name), ss) - : map (\(cname, _) -> (IdeNamespaced IdeNSValue (P.runProperName cname), ss)) ctors + (IdeNamespaced IdeNSType (P.runProperName name), ss) : map dtorSpan ctors P.FixityDeclaration (ss, _) (Left (P.ValueFixity _ _ opName)) -> [(IdeNamespaced IdeNSValue (P.runOpName opName), ss)] P.FixityDeclaration (ss, _) (Right (P.TypeFixity _ _ opName)) -> @@ -101,6 +100,9 @@ extractSpans d = case d of [(IdeNamespaced IdeNSKind (P.runProperName name), ss)] _ -> [] where + dtorSpan :: P.DataConstructorDeclaration -> (IdeNamespaced, P.SourceSpan) + dtorSpan P.DataConstructorDeclaration{ P.dataCtorName = name, P.dataCtorAnn = (ss, _) } = + (IdeNamespaced IdeNSValue (P.runProperName name), ss) -- We need this special case to be able to also get the position info for -- typeclass member functions. Typedeclarations would clash with value -- declarations for non-typeclass members, which is why we can't handle them diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index d29f446..419b529 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -227,6 +227,7 @@ resolveLocationsForModule (defs, types) decls = convertDeclaration (IdeDeclarationAnn ann d) = convertDeclaration' annotateFunction annotateValue + annotateDataConstructor annotateType annotateKind annotateModule @@ -236,6 +237,7 @@ resolveLocationsForModule (defs, types) decls = , _annTypeAnnotation = Map.lookup x types }) annotateValue x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSValue x) defs}) + annotateDataConstructor x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSValue x) defs}) annotateType x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSType x) defs}) annotateKind x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSKind x) defs}) annotateModule x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSModule x) defs}) @@ -246,9 +248,10 @@ convertDeclaration' -> (Text -> IdeDeclaration -> IdeDeclarationAnn) -> (Text -> IdeDeclaration -> IdeDeclarationAnn) -> (Text -> IdeDeclaration -> IdeDeclarationAnn) + -> (Text -> IdeDeclaration -> IdeDeclarationAnn) -> IdeDeclaration -> IdeDeclarationAnn -convertDeclaration' annotateFunction annotateValue annotateType annotateKind annotateModule d = +convertDeclaration' annotateFunction annotateValue annotateDataConstructor annotateType annotateKind annotateModule d = case d of IdeDeclValue v -> annotateFunction (v ^. ideValueIdent) d @@ -257,7 +260,7 @@ convertDeclaration' annotateFunction annotateValue annotateType annotateKind ann IdeDeclTypeSynonym s -> annotateType (s ^. ideSynonymName . properNameT) d IdeDeclDataConstructor dtor -> - annotateValue (dtor ^. ideDtorName . properNameT) d + annotateDataConstructor (dtor ^. ideDtorName . properNameT) d IdeDeclTypeClass tc -> annotateType (tc ^. ideTCName . properNameT) d IdeDeclValueOperator operator -> @@ -284,12 +287,16 @@ resolveDocumentationForModule resolveDocumentationForModule (P.Module _ moduleComments moduleName sdecls _) decls = map convertDecl decls where comments :: Map P.Name [P.Comment] - comments = Map.insert (P.ModName moduleName) moduleComments $ Map.fromListWith (flip (<>)) $ mapMaybe (\d -> - case name d of - Just name' -> Just (name', snd $ P.declSourceAnn d) - _ -> Nothing) + comments = Map.insert (P.ModName moduleName) moduleComments $ Map.fromListWith (flip (<>)) $ concatMap (\case + P.DataDeclaration (_, cs) _ ctorName _ ctors -> + (P.TyName ctorName, cs) : map dtorComments ctors + decl -> + maybe [] (\name' -> [(name', snd (P.declSourceAnn decl))]) (name decl)) sdecls + dtorComments :: P.DataConstructorDeclaration -> (P.Name, [P.Comment]) + dtorComments dcd = (P.DctorName (P.dataCtorName dcd), snd (P.dataCtorAnn dcd)) + name :: P.Declaration -> Maybe P.Name name (P.TypeDeclaration d) = Just $ P.IdentName $ P.tydeclIdent d name decl = P.declName decl @@ -299,6 +306,7 @@ resolveDocumentationForModule (P.Module _ moduleComments moduleName sdecls _) de convertDeclaration' (annotateValue . P.IdentName) (annotateValue . P.IdentName . P.Ident) + (annotateValue . P.DctorName . P.ProperName) (annotateValue . P.TyName . P.ProperName) (annotateValue . P.KiName . P.ProperName) (annotateValue . P.ModName . P.moduleNameFromString) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index f60f565..f983266 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -22,7 +22,7 @@ import Data.Function (on) import Data.Foldable (for_) import Data.List (foldl', sortBy) import qualified Data.List.NonEmpty as NEL -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Text as T @@ -121,19 +121,22 @@ make ma@MakeActions{..} ms = do (importPrim <$> CST.resFull m) (deps `inOrderOf` map (getModuleName . CST.resPartial) sorted) - -- Wait for all threads to complete, and collect errors. - errors <- BuildPlan.collectErrors buildPlan + -- Wait for all threads to complete, and collect results (and errors). + results <- BuildPlan.collectResults buildPlan -- All threads have completed, rethrow any caught errors. + let errors = mapMaybe buildJobFailure $ M.elems results unless (null errors) $ throwError (mconcat errors) - -- Collect all ExternsFiles - results <- BuildPlan.collectResults buildPlan - -- Here we return all the ExternsFile in the ordering of the topological sort, -- so they can be folded into an Environment. This result is used in the tests -- and in PSCI. - let lookupResult mn = fromMaybe (internalError "make: module not found in results") (M.lookup mn results) + let lookupResult mn = + snd + . fromMaybe (internalError "make: module's build job did not succeed") + . buildJobSuccess + . fromMaybe (internalError "make: module not found in results") + $ M.lookup mn results return (map (lookupResult . getModuleName . CST.resPartial) sorted) where @@ -168,21 +171,21 @@ make ma@MakeActions{..} ms = do inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys buildModule :: BuildPlan -> ModuleName -> FilePath -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> m () - buildModule buildPlan moduleName fp mres deps = flip catchError (complete Nothing . Just) $ do - m <- CST.unwrapParserError fp mres - -- We need to wait for dependencies to be built, before checking if the current - -- module should be rebuilt, so the first thing to do is to wait on the - -- MVars for the module's dependencies. - mexterns <- fmap unzip . sequence <$> traverse (getResult buildPlan) deps - - case mexterns of - Just (_, externs) -> do - (exts, warnings) <- listen $ rebuildModule ma externs m - complete (Just (warnings, exts)) Nothing - Nothing -> complete Nothing Nothing - where - complete :: Maybe (MultipleErrors, ExternsFile) -> Maybe MultipleErrors -> m () - complete = BuildPlan.markComplete buildPlan moduleName + buildModule buildPlan moduleName fp mres deps = do + result <- flip catchError (return . BuildJobFailed) $ do + m <- CST.unwrapParserError fp mres + -- We need to wait for dependencies to be built, before checking if the current + -- module should be rebuilt, so the first thing to do is to wait on the + -- MVars for the module's dependencies. + mexterns <- fmap unzip . sequence <$> traverse (getResult buildPlan) deps + + case mexterns of + Just (_, externs) -> do + (exts, warnings) <- listen $ rebuildModule ma externs m + return $ BuildJobSucceeded warnings exts + Nothing -> return BuildJobSkipped + + BuildPlan.markComplete buildPlan moduleName result -- | Infer the module name for a module by looking for the same filename with -- a .js extension. diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs index 7f728f2..7e4d81e 100644 --- a/src/Language/PureScript/Make/BuildPlan.hs +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -1,8 +1,10 @@ module Language.PureScript.Make.BuildPlan ( BuildPlan() + , BuildJobResult(..) + , buildJobSuccess + , buildJobFailure , construct , getResult - , collectErrors , collectResults , markComplete , needsRebuild @@ -40,50 +42,56 @@ data Prebuilt = Prebuilt , pbExternsFile :: ExternsFile } -data BuildJob = BuildJob - { bjResult :: C.MVar (Maybe (MultipleErrors, ExternsFile)) - , bjErrors :: C.MVar (Maybe MultipleErrors) +newtype BuildJob = BuildJob + { bjResult :: C.MVar BuildJobResult + -- ^ Note: an empty MVar indicates that the build job has not yet finished. } +data BuildJobResult + = BuildJobSucceeded !MultipleErrors !ExternsFile + -- ^ Succeeded, with warnings and externs + -- + | BuildJobFailed !MultipleErrors + -- ^ Failed, with errors + + | BuildJobSkipped + -- ^ The build job was not run, because an upstream build job failed + +buildJobSuccess :: BuildJobResult -> Maybe (MultipleErrors, ExternsFile) +buildJobSuccess (BuildJobSucceeded warnings externs) = Just (warnings, externs) +buildJobSuccess _ = Nothing + +buildJobFailure :: BuildJobResult -> Maybe MultipleErrors +buildJobFailure (BuildJobFailed errors) = Just errors +buildJobFailure _ = Nothing + -- | Called when we finished compiling a module and want to report back the -- compilation result, as well as any potential errors that were thrown. markComplete :: (MonadBaseControl IO m) => BuildPlan -> ModuleName - -> Maybe (MultipleErrors, ExternsFile) - -> Maybe MultipleErrors + -> BuildJobResult -> m () -markComplete buildPlan moduleName result errors = do - let BuildJob rVar eVar = fromMaybe (internalError "make: markComplete no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan) +markComplete buildPlan moduleName result = do + let BuildJob rVar = fromMaybe (internalError "make: markComplete no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan) putMVar rVar result - putMVar eVar errors -- | Whether or not the module with the given ModuleName needs to be rebuilt needsRebuild :: BuildPlan -> ModuleName -> Bool needsRebuild bp moduleName = M.member moduleName (bpBuildJobs bp) --- | Collects errors for all modules that have been rebuilt. This will block --- until all outstanding build jobs are finished. -collectErrors - :: (MonadBaseControl IO m) - => BuildPlan - -> m [MultipleErrors] -collectErrors buildPlan = do - errors <- traverse readMVar $ map bjErrors $ M.elems (bpBuildJobs buildPlan) - pure (catMaybes errors) - --- | Collects ExternsFiles for all prebuilt as well as rebuilt modules. Panics --- if any build job returned an error. +-- | Collects results for all prebuilt as well as rebuilt modules. This will +-- block until all build jobs are finished. Prebuilt modules always return no +-- warnings. collectResults :: (MonadBaseControl IO m) => BuildPlan - -> m (M.Map ModuleName ExternsFile) + -> m (M.Map ModuleName BuildJobResult) collectResults buildPlan = do - let externs = M.map pbExternsFile (bpPrebuilt buildPlan) - barrierResults <- traverse (takeMVar . bjResult) $ bpBuildJobs buildPlan - let barrierExterns = M.map (snd . fromMaybe (internalError "make: externs were missing but no errors reported.")) barrierResults - pure (M.union externs barrierExterns) + let prebuiltResults = M.map (BuildJobSucceeded (MultipleErrors []) . pbExternsFile) (bpPrebuilt buildPlan) + barrierResults <- traverse (readMVar . bjResult) $ bpBuildJobs buildPlan + pure (M.union prebuiltResults barrierResults) -- | Gets the the build result for a given module name independent of whether it -- was rebuilt or prebuilt. Prebuilt modules always return no warnings. @@ -96,8 +104,9 @@ getResult buildPlan moduleName = case M.lookup moduleName (bpPrebuilt buildPlan) of Just es -> pure (Just (MultipleErrors [], pbExternsFile es)) - Nothing -> - readMVar $ bjResult $ fromMaybe (internalError "make: no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan) + Nothing -> do + r <- readMVar $ bjResult $ fromMaybe (internalError "make: no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan) + pure $ buildJobSuccess r -- | Constructs a BuildPlan for the given module graph. -- @@ -115,7 +124,7 @@ construct MakeActions{..} (sorted, graph) = do pure $ BuildPlan prebuilt buildJobs where makeBuildJob prev moduleName = do - buildJob <- BuildJob <$> C.newEmptyMVar <*> C.newEmptyMVar + buildJob <- BuildJob <$> C.newEmptyMVar pure (M.insert moduleName buildJob prev) findExistingExtern :: CST.PartialResult Module -> m (Maybe (ModuleName, Bool, Prebuilt)) diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index aabd707..0047b23 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -6,6 +6,7 @@ module Language.PureScript.Pretty.Types , PrettyPrintConstraint , convertPrettyPrintType , typeAsBox + , typeDiffAsBox , suggestedTypeAsBox , prettyPrintType , prettyPrintTypeWithUnicode @@ -22,7 +23,7 @@ import Control.Arrow ((<+>)) import Control.PatternArrows as PA import Data.Functor (($>)) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, catMaybes) import Data.Text (Text) import qualified Data.Text as T @@ -118,13 +119,13 @@ prettyPrintRowWith :: TypeRenderOptions -> Char -> Char -> [(Label, PrettyPrintT prettyPrintRowWith tro open close labels rest = case (labels, rest) of ([], Nothing) -> - text [open, close] + if troRowAsDiff tro then text [ open, ' ' ] <> text "..." <> text [ ' ', close ] else text [ open, close ] ([], Just _) -> text [ open, ' ' ] <> tailToPs rest <> text [ ' ', close ] _ -> vcat left $ zipWith (\(nm, ty) i -> nameAndTypeToPs (if i == 0 then open else ',') nm ty) labels [0 :: Int ..] ++ - [ tailToPs rest, text [close] ] + catMaybes [ rowDiff, pure $ tailToPs rest, pure $ text [close] ] where nameAndTypeToPs :: Char -> Label -> PrettyPrintType -> Box @@ -132,6 +133,8 @@ prettyPrintRowWith tro open close labels rest = doubleColon = if troUnicode tro then "∷" else "::" + rowDiff = if troRowAsDiff tro then Just (text "...") else Nothing + tailToPs :: Maybe PrettyPrintType -> Box tailToPs Nothing = nullBox tailToPs (Just other) = text "| " <> typeAsBox' other @@ -238,22 +241,32 @@ typeAsBox' = typeAsBoxImpl defaultOptions typeAsBox :: Int -> Type a -> Box typeAsBox maxDepth = typeAsBox' . convertPrettyPrintType maxDepth +typeDiffAsBox' :: PrettyPrintType -> Box +typeDiffAsBox' = typeAsBoxImpl diffOptions + +typeDiffAsBox :: Int -> Type a -> Box +typeDiffAsBox maxDepth = typeDiffAsBox' . convertPrettyPrintType maxDepth + suggestedTypeAsBox :: PrettyPrintType -> Box suggestedTypeAsBox = typeAsBoxImpl suggestingOptions data TypeRenderOptions = TypeRenderOptions { troSuggesting :: Bool , troUnicode :: Bool + , troRowAsDiff :: Bool } suggestingOptions :: TypeRenderOptions -suggestingOptions = TypeRenderOptions True False +suggestingOptions = TypeRenderOptions True False False defaultOptions :: TypeRenderOptions -defaultOptions = TypeRenderOptions False False +defaultOptions = TypeRenderOptions False False False + +diffOptions :: TypeRenderOptions +diffOptions = TypeRenderOptions False False True unicodeOptions :: TypeRenderOptions -unicodeOptions = TypeRenderOptions False True +unicodeOptions = TypeRenderOptions False True False typeAsBoxImpl :: TypeRenderOptions -> PrettyPrintType -> Box typeAsBoxImpl tro diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index fe9592d..99ddaf0 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -67,6 +67,7 @@ prettyPrintValue d (ObjectUpdateNested o ps) = prettyPrintValueAtom (d - 1) o `b printNode (key, Leaf val) = prettyPrintUpdateEntry d key val printNode (key, Branch val) = textT (prettyPrintObjectKey key) `beforeWithSpace` prettyPrintUpdate val prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg +prettyPrintValue d (Unused val) = prettyPrintValue d val prettyPrintValue d (Abs arg val) = text ('\\' : T.unpack (prettyPrintBinder arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) = text (T.unpack (runProperName (disqualify className)) ++ " ") <> prettyPrintValueAtom (d - 1) ps diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 063979a..fcf7f46 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -205,7 +205,7 @@ renameInModule imports (Module modSS coms mn decls exps) = fmap (bound,) $ DataDeclaration sa dtype name <$> updateTypeArguments args - <*> traverse (sndM (traverse (sndM updateTypesEverywhere))) dctors + <*> traverse (traverseDataCtorFields (traverse (sndM updateTypesEverywhere))) dctors updateDecl bound (TypeSynonymDeclaration sa name ps ty) = fmap (bound,) $ TypeSynonymDeclaration sa name diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 7480ecc..57fdb72 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -46,7 +46,7 @@ findExportable (Module _ _ mn ds _) = go exps'' (TypeDeclaration (TypeDeclarationData (ss', _) name _)) = exportValue ss' exps'' name source go _ _ = internalError "Invalid declaration in TypeClassDeclaration" updateExports exps (DataDeclaration (ss, _) _ tn _ dcs) = - exportType ss Internal exps tn (map fst dcs) source + exportType ss Internal exps tn (map dataCtorName dcs) source updateExports exps (TypeSynonymDeclaration (ss, _) tn _ _) = exportType ss Internal exps tn [] source updateExports exps (ExternDataDeclaration (ss, _) tn _) = diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 20a2e04..1d0bb8a 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -315,7 +315,8 @@ updateTypes goType = (goDecl, goExpr, goBinder) goDecl :: Declaration -> m Declaration goDecl (DataDeclaration sa@(ss, _) ddt name args dctors) = - DataDeclaration sa ddt name args <$> traverse (sndM (traverse (sndM (goType' ss)))) dctors + DataDeclaration sa ddt name args + <$> traverse (traverseDataCtorFields (traverse (sndM (goType' ss)))) dctors goDecl (ExternDeclaration sa@(ss, _) name ty) = ExternDeclaration sa name <$> goType' ss ty goDecl (TypeClassDeclaration sa@(ss, _) name args implies deps decls) = do diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 7686e71..761de6f 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -64,8 +64,8 @@ desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModu :: ModuleName -> ExternsDeclaration -> Maybe ((ModuleName, ProperName 'ClassName), TypeClassData) - fromExternsDecl mn (EDClass name args members implies deps) = Just ((mn, name), typeClass) where - typeClass = makeTypeClassData args members implies deps + fromExternsDecl mn (EDClass name args members implies deps tcIsEmpty) = Just ((mn, name), typeClass) where + typeClass = makeTypeClassData args members implies deps tcIsEmpty fromExternsDecl _ _ = Nothing desugarModule @@ -203,7 +203,7 @@ desugarDecl desugarDecl mn exps = go where go d@(TypeClassDeclaration sa name args implies deps members) = do - modify (M.insert (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps)) + modify (M.insert (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps False)) return (Nothing, d : typeClassDictionaryDeclaration sa name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members) go (TypeInstanceDeclaration _ _ _ _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared" go d@(TypeInstanceDeclaration sa _ _ name deps className tys (ExplicitInstance members)) = do diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index fa10eb6..82e11a7 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -205,7 +205,7 @@ deriveNewtypeInstance ss mn syns ndis className ds tys tyConNm dargs = do tyCon <- findTypeDecl ss tyConNm ds go tyCon where - go (DataDeclaration _ Newtype _ tyArgNames [(_, [(_, wrapped)])]) = do + go (DataDeclaration _ Newtype _ tyArgNames [(DataConstructorDeclaration _ _ [(_, wrapped)])]) = do -- The newtype might not be applied to all type arguments. -- This is okay as long as the newtype wraps something which ends with -- sufficiently many type applications to variables. @@ -337,9 +337,9 @@ deriveGenericRep ss mn syns ds tyConNm tyConArgs repTy = do compN n f = f . compN (n - 1) f makeInst - :: (ProperName 'ConstructorName, [(Ident, SourceType)]) + :: DataConstructorDeclaration -> m (SourceType, CaseAlternative, CaseAlternative) - makeInst (ctorName, args) = do + makeInst (DataConstructorDeclaration _ ctorName args) = do args' <- mapM (replaceAllTypeSynonymsM syns . snd) args (ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args' return ( srcTypeApp (srcTypeApp (srcTypeConstructor constructor) @@ -468,8 +468,8 @@ deriveEq ss mn syns ds tyConNm = do where catchAll = CaseAlternative [NullBinder, NullBinder] (unguarded (Literal ss (BooleanLiteral False))) - mkCtorClause :: (ProperName 'ConstructorName, [(Ident, SourceType)]) -> m CaseAlternative - mkCtorClause (ctorName, tys) = do + mkCtorClause :: DataConstructorDeclaration -> m CaseAlternative + mkCtorClause (DataConstructorDeclaration _ ctorName tys) = do identsL <- replicateM (length tys) (freshIdent "l") identsR <- replicateM (length tys) (freshIdent "r") tys' <- mapM (replaceAllTypeSynonymsM syns . snd) tys @@ -547,8 +547,8 @@ deriveOrd ss mn syns ds tyConNm = do ordCompare1 :: Expr -> Expr -> Expr ordCompare1 = App . App (Var ss (Qualified (Just dataOrd) (Ident C.compare1))) - mkCtorClauses :: ((ProperName 'ConstructorName, [(Ident, SourceType)]), Bool) -> m [CaseAlternative] - mkCtorClauses ((ctorName, tys), isLast) = do + mkCtorClauses :: (DataConstructorDeclaration, Bool) -> m [CaseAlternative] + mkCtorClauses ((DataConstructorDeclaration _ ctorName tys), isLast) = do identsL <- replicateM (length tys) (freshIdent "l") identsR <- replicateM (length tys) (freshIdent "r") tys' <- mapM (replaceAllTypeSynonymsM syns . snd) tys @@ -622,7 +622,7 @@ deriveNewtype ss mn syns ds tyConNm tyConArgs unwrappedTy = do checkNewtype name dctors wrappedIdent <- freshIdent "n" unwrappedIdent <- freshIdent "a" - let (ctorName, [(_, ty)]) = head dctors + let (DataConstructorDeclaration _ ctorName [(_, ty)]) = head dctors ty' <- replaceAllTypeSynonymsM syns ty let inst = [ ValueDecl (ss', []) (Ident "wrap") Public [] $ unguarded $ @@ -707,8 +707,8 @@ deriveFunctor ss mn syns ds tyConNm = do lam ss' f . lamCase ss' m <$> mapM (mkCtorClause iTy f) ctors mkMapFunction _ = internalError "mkMapFunction: expected DataDeclaration" - mkCtorClause :: Text -> Ident -> (ProperName 'ConstructorName, [(Ident, SourceType)]) -> m CaseAlternative - mkCtorClause iTyName f (ctorName, ctorTys) = do + mkCtorClause :: Text -> Ident -> DataConstructorDeclaration -> m CaseAlternative + mkCtorClause iTyName f (DataConstructorDeclaration _ ctorName ctorTys) = do idents <- replicateM (length ctorTys) (freshIdent "v") ctorTys' <- mapM (replaceAllTypeSynonymsM syns . snd) ctorTys args <- zipWithM transformArg idents ctorTys' diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index ecfdeb9..b9ae232 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -12,7 +12,6 @@ module Language.PureScript.TypeChecker import Prelude.Compat import Protolude (ordNub) -import Control.Arrow (second) import Control.Monad (when, unless, void, forM) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), modify, gets) @@ -50,13 +49,14 @@ addDataType -> DataDeclType -> ProperName 'TypeName -> [(Text, Maybe SourceKind)] - -> [(ProperName 'ConstructorName, [(Ident, SourceType)])] + -> [DataConstructorDeclaration] -> SourceKind -> m () addDataType moduleName dtype name args dctors ctorKind = do env <- getEnv - putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args (map (second (map snd)) dctors)) (types env) } - for_ dctors $ \(dctor, fields) -> + let mapDataCtor (DataConstructorDeclaration _ ctorName vars) = (ctorName, snd <$> vars) + putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args (map mapDataCtor dctors)) (types env) } + for_ dctors $ \(DataConstructorDeclaration _ dctor fields) -> warnAndRethrow (addHint (ErrorInDataConstructor dctor)) $ addDataConstructor moduleName dtype name (map fst args) dctor fields @@ -125,17 +125,23 @@ addTypeClass -> m () addTypeClass qualifiedClassName args implies dependencies ds = do env <- getEnv - traverse_ (checkMemberIsUsable (typeSynonyms env)) classMembers + let newClass = mkNewClass env + traverse_ (checkMemberIsUsable newClass (typeSynonyms env)) classMembers modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert qualifiedClassName newClass (typeClasses . checkEnv $ st) } } where classMembers :: [(Ident, SourceType)] classMembers = map toPair ds - newClass :: TypeClassData - newClass = makeTypeClassData args classMembers implies dependencies + mkNewClass :: Environment -> TypeClassData + mkNewClass env = makeTypeClassData args classMembers implies dependencies ctIsEmpty + where + ctIsEmpty = null classMembers && all (typeClassIsEmpty . findSuperClass) implies + findSuperClass c = case M.lookup (constraintClass c) (typeClasses env) of + Just tcd -> tcd + Nothing -> internalError "Unknown super class in TypeClassDeclaration" - coveringSets :: [S.Set Int] - coveringSets = S.toList (typeClassCoveringSets newClass) + coveringSets :: TypeClassData -> [S.Set Int] + coveringSets = S.toList . typeClassCoveringSets argToIndex :: Text -> Maybe Int argToIndex = flip M.lookup $ M.fromList (zipWith ((,) . fst) args [0..]) @@ -146,11 +152,11 @@ addTypeClass qualifiedClassName args implies dependencies ds = do -- Currently we are only checking usability based on the type class currently -- being defined. If the mentioned arguments don't include a covering set, -- then we won't be able to find a instance. - checkMemberIsUsable :: T.SynonymMap -> (Ident, SourceType) -> m () - checkMemberIsUsable syns (ident, memberTy) = do + checkMemberIsUsable :: TypeClassData -> T.SynonymMap -> (Ident, SourceType) -> m () + checkMemberIsUsable newClass syns (ident, memberTy) = do memberTy' <- T.replaceAllTypeSynonymsM syns memberTy let mentionedArgIndexes = S.fromList (mapMaybe argToIndex (freeTypeVariables memberTy')) - let leftovers = map (`S.difference` mentionedArgIndexes) coveringSets + let leftovers = map (`S.difference` mentionedArgIndexes) (coveringSets newClass) unless (any null leftovers) . throwError . errorMessage $ let @@ -237,7 +243,7 @@ typeCheckAll moduleName _ = traverse go warnAndRethrow (addHint (ErrorInTypeConstructor name) . addHint (positionedError ss)) $ do when (dtype == Newtype) $ checkNewtype name dctors checkDuplicateTypeArguments $ map fst args - ctorKind <- kindsOf True moduleName name args (concatMap (fmap snd . snd) dctors) + ctorKind <- kindsOf True moduleName name args (concatMap (fmap snd . dataCtorFields) dctors) let args' = args `withKinds` ctorKind addDataType moduleName dtype name args' dctors ctorKind return $ DataDeclaration sa dtype name args dctors @@ -248,7 +254,7 @@ typeCheckAll moduleName _ = traverse go bindingGroupNames = ordNub ((syns^..traverse._2) ++ (dataDecls^..traverse._3)) sss = fmap declSourceSpan tys warnAndRethrow (addHint (ErrorInDataBindingGroup bindingGroupNames) . addHint (PositionedError sss)) $ do - (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(sa, _, name, args, dctors) -> (sa, name, args, concatMap (fmap snd . snd) dctors)) dataDecls) + (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(sa, _, name, args, dctors) -> (sa, name, args, concatMap (fmap snd . dataCtorFields) dctors)) dataDecls) for_ (zip dataDecls data_ks) $ \((_, dtype, name, args, dctors), ctorKind) -> do when (dtype == Newtype) $ checkNewtype name dctors checkDuplicateTypeArguments $ map fst args @@ -497,9 +503,9 @@ checkNewtype :: forall m . MonadError MultipleErrors m => ProperName 'TypeName - -> [(ProperName 'ConstructorName, [(Ident, SourceType)])] + -> [DataConstructorDeclaration] -> m () -checkNewtype _ [(_, [_])] = return () +checkNewtype _ [(DataConstructorDeclaration _ _ [_])] = return () checkNewtype name _ = throwError . errorMessage $ InvalidNewtype name -- | diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 23f62f9..dee68a9 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -207,9 +207,14 @@ entails SolverOptions{..} constraint context hints = -- We need information about functional dependencies, so we have to look up the class -- name in the environment: classesInScope <- lift . lift $ gets (typeClasses . checkEnv) - TypeClassData{ typeClassDependencies } <- case M.lookup className' classesInScope of - Nothing -> throwError . errorMessage $ UnknownClass className' - Just tcd -> pure tcd + + TypeClassData + { typeClassDependencies + , typeClassIsEmpty + } <- case M.lookup className' classesInScope of + Nothing -> throwError . errorMessage $ UnknownClass className' + Just tcd -> pure tcd + let instances = do chain <- groupBy ((==) `on` tcdChain) $ sortBy (compare `on` (tcdChain &&& tcdIndex)) $ @@ -245,11 +250,14 @@ entails SolverOptions{..} constraint context hints = let subst'' = fmap (substituteType currentSubst') subst' -- Solve any necessary subgoals args <- solveSubgoals subst'' (tcdDependencies tcd) + initDict <- lift . lift $ mkDictionary (tcdValue tcd) args + let match = foldr (\(className, index) dict -> subclassDictionaryValue dict className index) initDict (tcdPath tcd) - return match + + return (if typeClassIsEmpty then Unused match else match) Unsolved unsolved -> do -- Generate a fresh name for the unsolved constraint's new dictionary ident <- freshIdent ("dict" <> runProperName (disqualify (constraintClass unsolved))) @@ -339,7 +347,7 @@ entails SolverOptions{..} constraint context hints = -- We need subgoal dictionaries to appear in the term somewhere -- If there aren't any then the dictionary is just undefined useEmptyDict :: Maybe [Expr] -> Expr - useEmptyDict args = foldl (App . Abs (VarBinder nullSourceSpan UnusedIdent)) valUndefined (fold args) + useEmptyDict args = Unused (foldl (App . Abs (VarBinder nullSourceSpan UnusedIdent)) valUndefined (fold args)) -- Make a dictionary from subgoal dictionaries by applying the correct function mkDictionary :: Evidence -> Maybe [Expr] -> m Expr diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 65625f4..a9afdc6 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -173,7 +173,8 @@ unifyRows r1 r2 = sequence_ matches *> uncurry unifyTails rest where solveType u1 (rowFromList (sd2, rest')) solveType u2 (rowFromList (sd1, rest')) unifyTails _ _ = - throwError . errorMessage $ TypesDoNotUnify r1 r2 + withErrorMessageHint (ErrorUnifyingTypes r1 r2) $ + throwError . errorMessage $ TypesDoNotUnify r1 r2 -- | -- Replace a single type variable with a new unification variable |