summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--purescript.cabal2
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs67
-rw-r--r--src/Language/PureScript/Docs/Types.hs7
-rw-r--r--tests/TestDocs.hs60
4 files changed, 80 insertions, 56 deletions
diff --git a/purescript.cabal b/purescript.cabal
index 45b2f80..4bd0b62 100644
--- 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
index 2631d62..a6adeca 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -138,8 +138,8 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
-- 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 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
--
-- 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 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
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
-
- -- |
- -- 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
+ 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
+ ]
+
+ 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
index f18648b..e69eb87 100644
--- a/src/Language/PureScript/Docs/Types.hs
+++ b/src/Language/PureScript/Docs/Types.hs
@@ -397,8 +397,9 @@ data LinkLocation
| 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 @@ getLink LinksContext{..} curMn namespace target containingMod = do
}
where
- getLinkLocation = normalLinkLocation <|> builtinLinkLocation
+ getLinkLocation = builtinLinkLocation <|> normalLinkLocation
normalLinkLocation = do
case containingMod of
diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs
index 46ce23d..8c6abaf 100644
--- 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 @@ main = pushd "examples/docs" $ do
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 @@ data Assertion
-- | 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 @@ data AssertionFailure
-- | 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 @@ data AssertionResult
| 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 @@ runAssertion assertion Docs.Module{..} =
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 @@ runAssertion assertion Docs.Module{..} =
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 @@ checkConstrained ty tyClass =
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 @@ testCases =
, ("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 @@ testCases =
]
where
- n = P.moduleNameFromString . T.pack
+ n = P.moduleNameFromString
pkg str = let Right p = parsePackageName str in p
hasTypeVar varName =