diff --git a/purescript.cabal b/purescript.cabal --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.10.6 +version: 0.10.7 cabal-version: >=1.8 build-type: Simple license: BSD3 diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -138,8 +138,8 @@ -- Generate code in the simplified Javascript intermediate representation for a declaration -- bindToJs :: Bind Ann -> m [JS] - bindToJs (NonRec ann ident val) = nonRecToJS ann ident val - bindToJs (Rec vals) = concat <$> forM vals (uncurry . uncurry $ nonRecToJS) + bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val + bindToJs (Rec vals) = forM vals (uncurry . uncurry $ nonRecToJS) -- | -- Generate code in the simplified Javascript intermediate representation for a single non-recursive @@ -147,22 +147,15 @@ -- -- The main purpose of this function is to handle code generation for comments. -- - nonRecToJS :: Ann -> Ident -> Expr Ann -> m [JS] + nonRecToJS :: Ann -> Ident -> Expr Ann -> m JS nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do withoutComment <- asks optionsNoComments if withoutComment then nonRecToJS a i (modifyAnn removeComments e) - else withHead (JSComment Nothing com) <$> nonRecToJS a i (modifyAnn removeComments e) - where - withHead _ [] = [] - withHead f (x:xs) = f x : xs + else JSComment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e) nonRecToJS (ss, _, _, _) ident val = do - case constructorToJs ident val of - Just jss -> - traverse (withPos ss) jss - Nothing -> do - js <- valueToJs val - return <$> (withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js)) + js <- valueToJs val + withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js) withPos :: Maybe SourceSpan -> JS -> m JS withPos (Just ss) js = do @@ -258,37 +251,23 @@ JSObjectLiteral Nothing [("create", JSFunction Nothing Nothing ["value"] (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))]) - valueToJs' (Constructor _ _ (ProperName ctor) _) = - internalError $ "Unexpected constructor definition: " ++ T.unpack ctor + valueToJs' (Constructor _ _ (ProperName ctor) []) = + return $ iife (properToJs ctor) [ JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing []) + , JSAssignment Nothing (accessorString "value" (JSVar Nothing (properToJs ctor))) + (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) []) ] + valueToJs' (Constructor _ _ (ProperName ctor) fields) = + let constructor = + let body = [ JSAssignment Nothing ((accessorString $ mkString $ identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ] + in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body) + createFn = + let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields) + in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields + in return $ iife (properToJs ctor) [ constructor + , JSAssignment Nothing (accessorString "create" (JSVar Nothing (properToJs ctor))) createFn + ] - -- | - -- Attempt to generate code in the simplified JS intermediate representation for a constructor definition. - -- If the argument is not a constructor, this returns Nothing. - -- - constructorToJs :: Ident -> Expr Ann -> Maybe [JS] - constructorToJs ident (Constructor _ _ (ProperName ctor) fs) = - Just jss - where - mkAccessor name = JSAssignment Nothing (accessorString name (JSVar Nothing (identToJs ident))) - jss = case fs of - [] -> - [ JSVariableIntroduction Nothing (identToJs ident) (Just $ - JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing [])) - , mkAccessor "value" $ - JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (identToJs ident)) [] - ] - fields -> - let constructor = - let body = [ JSAssignment Nothing ((accessorString $ mkString $ identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ] - in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body) - createFn = - let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields) - in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields - in [ constructor - , mkAccessor "create" createFn - ] - constructorToJs _ _ = - Nothing + iife :: Text -> [JS] -> JS + iife v exprs = JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing $ exprs ++ [JSReturn Nothing $ JSVar Nothing v])) [] literalToValueJS :: Literal (Expr Ann) -> m JS literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i) diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -397,8 +397,9 @@ | BuiltinModule P.ModuleName deriving (Show, Eq, Ord) --- | Given a links context, a thing to link to (either a value or a type), and --- its containing module, attempt to create a DocLink. +-- | Given a links context, the current module name, the namespace of a thing +-- to link to, its title, and its containing module, attempt to create a +-- DocLink. getLink :: LinksContext -> P.ModuleName -> Namespace -> Text -> ContainingModule -> Maybe DocLink getLink LinksContext{..} curMn namespace target containingMod = do location <- getLinkLocation @@ -409,7 +410,7 @@ } where - getLinkLocation = normalLinkLocation <|> builtinLinkLocation + getLinkLocation = builtinLinkLocation <|> normalLinkLocation normalLinkLocation = do case containingMod of diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} @@ -44,11 +45,12 @@ res <- Publish.preparePackage publishOpts case res of Left e -> Publish.printErrorToStdout e >> exitFailure - Right Docs.Package{..} -> + Right pkg@Docs.Package{..} -> forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) -> let mdl = takeJust ("module not found in docs: " ++ T.unpack (P.runModuleName mn)) (find ((==) mn . Docs.modName) pkgModules) - in forM_ pragmas (`runAssertionIO` mdl) + linksCtx = Docs.getLinksContext pkg + in forM_ pragmas (\a -> runAssertionIO a linksCtx mdl) takeJust :: String -> Maybe a -> a @@ -82,6 +84,11 @@ -- | Assert that there should be some declarations re-exported from a -- particular module in a particular package. | ShouldHaveReExport (Docs.InPackage P.ModuleName) + -- | Assert that a link to some specific declaration exists within the + -- rendered code for a declaration. Fields are: local module, local + -- declaration title, title of linked declaration, namespace of linked + -- declaration, destination of link. + | ShouldHaveLink P.ModuleName Text Text Docs.Namespace Docs.LinkLocation deriving (Show) newtype ShowFn a = ShowFn a @@ -119,6 +126,17 @@ -- | A module was missing re-exports from a particular module. -- Fields: module name, expected re-export, actual re-exports. | ReExportMissing P.ModuleName (Docs.InPackage P.ModuleName) [Docs.InPackage P.ModuleName] + -- | Expected to find some other declaration mentioned in this declaration's + -- rendered code, but did not find anything. + -- Fields: module name, declaration title, title of declaration which was + -- expected but not found in. + | LinkedDeclarationMissing P.ModuleName Text Text + -- | Expected one link location for a declaration mentioned in some other + -- declaration's rendered code, but found a different one. Fields: module + -- name, title of the local declaration which links to some other + -- declaration, title of the linked declaration, expected location, actual + -- location. + | BadLinkLocation P.ModuleName Text Text Docs.LinkLocation Docs.LinkLocation deriving (Show) data AssertionResult @@ -126,8 +144,8 @@ | Fail AssertionFailure deriving (Show) -runAssertion :: Assertion -> Docs.Module -> AssertionResult -runAssertion assertion Docs.Module{..} = +runAssertion :: Assertion -> Docs.LinksContext -> Docs.Module -> AssertionResult +runAssertion assertion linksCtx Docs.Module{..} = case assertion of ShouldBeDocumented mn decl children -> case findChildren decl (declarationsFor mn) of @@ -214,6 +232,19 @@ then Pass else Fail (ReExportMissing modName reExp reExps) + ShouldHaveLink mn decl destTitle destNs expectedLoc -> + findDecl mn decl $ \decl' -> + let + rendered = Docs.renderDeclaration decl' + in + case extract rendered destNs destTitle of + Just (Docs.linkLocation -> actualLoc) -> + if expectedLoc == actualLoc + then Pass + else Fail (BadLinkLocation mn decl destTitle expectedLoc actualLoc) + Nothing -> + Fail (LinkedDeclarationMissing mn decl destTitle) + where declarationsFor mn = if mn == modName @@ -232,6 +263,17 @@ childrenTitles = map Docs.cdeclTitle . Docs.declChildren + extract :: Docs.RenderedCode -> Docs.Namespace -> Text -> Maybe Docs.DocLink + extract rc ns title = getFirst (Docs.outputWith (First . go) rc) >>= getLink + where + getLink = + Docs.getLink linksCtx (P.moduleNameFromString "$DocsTest") ns title + go = \case + Docs.Symbol ns' title' (Docs.Link containingMod) + | ns' == ns && title' == title -> Just containingMod + _ -> + Nothing + checkConstrained :: P.Type -> Text -> Bool checkConstrained ty tyClass = -- Note that we don't recurse on ConstrainedType if none of the constraints @@ -248,10 +290,10 @@ matches className = (==) className . P.runProperName . P.disqualify . P.constraintClass -runAssertionIO :: Assertion -> Docs.Module -> IO () -runAssertionIO assertion mdl = do +runAssertionIO :: Assertion -> Docs.LinksContext -> Docs.Module -> IO () +runAssertionIO assertion linksCtx mdl = do putStrLn ("In " ++ T.unpack (P.runModuleName (Docs.modName mdl)) ++ ": " ++ show assertion) - case runAssertion assertion mdl of + case runAssertion assertion linksCtx mdl of Pass -> pure () Fail reason -> do putStrLn ("Failed: " <> show reason) @@ -276,6 +318,8 @@ , ("Example2", [ ShouldBeDocumented (n "Example2") "one" [] , ShouldBeDocumented (n "Example2") "two" [] + + , ShouldHaveLink (n "Example2") "one" "Int" Docs.TypeLevel (Docs.BuiltinModule (n "Prim")) ]) , ("UTF8", @@ -359,7 +403,7 @@ ] where - n = P.moduleNameFromString . T.pack + n = P.moduleNameFromString pkg str = let Right p = parsePackageName str in p hasTypeVar varName =