summaryrefslogtreecommitdiff
path: root/src/Language/PureScript
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/PureScript')
-rw-r--r--src/Language/PureScript/AST/Declarations.hs17
-rw-r--r--src/Language/PureScript/AST/Exported.hs2
-rw-r--r--src/Language/PureScript/AST/Traversals.hs11
-rw-r--r--src/Language/PureScript/Bundle.hs97
-rw-r--r--src/Language/PureScript/CST/Convert.hs17
-rw-r--r--src/Language/PureScript/CST/Layout.hs9
-rw-r--r--src/Language/PureScript/CoreFn/Desugar.hs13
-rw-r--r--src/Language/PureScript/CoreImp/Optimizer/TCO.hs4
-rw-r--r--src/Language/PureScript/Docs/Convert/Single.hs6
-rw-r--r--src/Language/PureScript/Docs/Prim.hs2
-rw-r--r--src/Language/PureScript/Environment.hs27
-rw-r--r--src/Language/PureScript/Errors.hs53
-rw-r--r--src/Language/PureScript/Externs.hs5
-rw-r--r--src/Language/PureScript/Ide/SourceFile.hs6
-rw-r--r--src/Language/PureScript/Ide/State.hs20
-rw-r--r--src/Language/PureScript/Make.hs47
-rw-r--r--src/Language/PureScript/Make/BuildPlan.hs67
-rw-r--r--src/Language/PureScript/Pretty/Types.hs25
-rw-r--r--src/Language/PureScript/Pretty/Values.hs1
-rw-r--r--src/Language/PureScript/Sugar/Names.hs2
-rw-r--r--src/Language/PureScript/Sugar/Names/Exports.hs2
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs3
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs6
-rwxr-xr-xsrc/Language/PureScript/Sugar/TypeClasses/Deriving.hs20
-rw-r--r--src/Language/PureScript/TypeChecker.hs38
-rw-r--r--src/Language/PureScript/TypeChecker/Entailment.hs18
-rw-r--r--src/Language/PureScript/TypeChecker/Unify.hs3
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