purescript 0.10.6 → 0.10.7
raw patch · 4 files changed
+79/−55 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- purescript.cabal +1/−1
- src/Language/PureScript/CodeGen/JS.hs +22/−43
- src/Language/PureScript/Docs/Types.hs +4/−3
- tests/TestDocs.hs +52/−8
purescript.cabal view
@@ -1,5 +1,5 @@ name: purescript-version: 0.10.6+version: 0.10.7 cabal-version: >=1.8 build-type: Simple license: BSD3
src/Language/PureScript/CodeGen/JS.hs view
@@ -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)
src/Language/PureScript/Docs/Types.hs view
@@ -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
tests/TestDocs.hs view
@@ -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 =