version 0.10.70.10.7

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 =