git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge remote-tracking branch 'pure11/pure11' into native
d6d3eb3Andy Arvanitis
purescript.cabal+1−1
compare with golang
unifiedsplit
@@ -1,5 +1,5 @@
1name: purescript
1name: purescript
2−version: 0.10.6
2+version: 0.10.7
3cabal-version: >=1.8
3cabal-version: >=1.8
4build-type: Simple
4build-type: Simple
5license: BSD3
5license: BSD3
src/Language/PureScript/CodeGen/JS.hs+23−44
@@ -138,8 +138,8 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
138 -- Generate code in the simplified Javascript intermediate representation for a declaration
138 -- Generate code in the simplified Javascript intermediate representation for a declaration
139 --
139 --
140 bindToJs :: Bind Ann -> m [JS]
140 bindToJs :: Bind Ann -> m [JS]
141− bindToJs (NonRec ann ident val) = nonRecToJS ann ident val
141+ bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val
142− bindToJs (Rec vals) = concat <$> forM vals (uncurry . uncurry $ nonRecToJS)
142+ bindToJs (Rec vals) = forM vals (uncurry . uncurry $ nonRecToJS)
143
143
144 -- |
144 -- |
145 -- Generate code in the simplified Javascript intermediate representation for a single non-recursive
145 -- 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_ =
147 --
147 --
148 -- The main purpose of this function is to handle code generation for comments.
148 -- The main purpose of this function is to handle code generation for comments.
149 --
149 --
150− nonRecToJS :: Ann -> Ident -> Expr Ann -> m [JS]
150+ nonRecToJS :: Ann -> Ident -> Expr Ann -> m JS
151 nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
151 nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
152 withoutComment <- asks optionsNoComments
152 withoutComment <- asks optionsNoComments
153 if withoutComment
153 if withoutComment
154 then nonRecToJS a i (modifyAnn removeComments e)
154 then nonRecToJS a i (modifyAnn removeComments e)
155− else withHead (JSComment Nothing com) <$> nonRecToJS a i (modifyAnn removeComments e)
155+ else JSComment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e)
156− where
157− withHead _ [] = []
158− withHead f (x:xs) = f x : xs
159 nonRecToJS (ss, _, _, _) ident val = do
156 nonRecToJS (ss, _, _, _) ident val = do
160− case constructorToJs ident val of
161− Just jss ->
162− traverse (withPos ss) jss
163− Nothing -> do
164− js <- valueToJs val
157+ js <- valueToJs val
165− return <$> (withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js))
158+ withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js)
166
159
167 withPos :: Maybe SourceSpan -> JS -> m JS
160 withPos :: Maybe SourceSpan -> JS -> m JS
168 withPos (Just ss) js = do
161 withPos (Just ss) js = do
@@ -258,37 +251,23 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
258 JSObjectLiteral Nothing [("create",
251 JSObjectLiteral Nothing [("create",
259 JSFunction Nothing Nothing ["value"]
252 JSFunction Nothing Nothing ["value"]
260 (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))])
253 (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))])
261− valueToJs' (Constructor _ _ (ProperName ctor) _) =
254+ valueToJs' (Constructor _ _ (ProperName ctor) []) =
262− internalError $ "Unexpected constructor definition: " ++ T.unpack ctor
263−
264− -- |
265− -- Attempt to generate code in the simplified JS intermediate representation for a constructor definition.
266− -- If the argument is not a constructor, this returns Nothing.
267− --
268− constructorToJs :: Ident -> Expr Ann -> Maybe [JS]
269− constructorToJs ident (Constructor _ _ (ProperName ctor) fs) =
270− Just jss
271− where
272− mkAccessor name = JSAssignment Nothing (accessorString name (JSVar Nothing (identToJs ident)))
273− jss = case fs of
274− [] ->
275− [ JSVariableIntroduction Nothing (identToJs ident) (Just $
276− JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing []))
255+ return $ iife (properToJs ctor) [ JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing [])
277− , mkAccessor "value" $
256+ , JSAssignment Nothing (accessorString "value" (JSVar Nothing (properToJs ctor)))
278− JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (identToJs ident)) []
257+ (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) []) ]
279− ]
258+ valueToJs' (Constructor _ _ (ProperName ctor) fields) =
280− fields ->
281− let constructor =
259+ let constructor =
282− let body = [ JSAssignment Nothing ((accessorString $ mkString $ identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]
260+ let body = [ JSAssignment Nothing ((accessorString $ mkString $ identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]
283− in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body)
261+ in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body)
284− createFn =
262+ createFn =
285− let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields)
263+ let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields)
286− in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields
264+ in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields
287− in [ constructor
265+ in return $ iife (properToJs ctor) [ constructor
288− , mkAccessor "create" createFn
266+ , JSAssignment Nothing (accessorString "create" (JSVar Nothing (properToJs ctor))) createFn
289− ]
267+ ]
290− constructorToJs _ _ =
268+
291− Nothing
269+ iife :: Text -> [JS] -> JS
270+ iife v exprs = JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing $ exprs ++ [JSReturn Nothing $ JSVar Nothing v])) []
292
271
293 literalToValueJS :: Literal (Expr Ann) -> m JS
272 literalToValueJS :: Literal (Expr Ann) -> m JS
294 literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i)
273 literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i)
src/Language/PureScript/Docs/Types.hs+4−3
@@ -397,8 +397,9 @@ data LinkLocation
397 | BuiltinModule P.ModuleName
397 | BuiltinModule P.ModuleName
398 deriving (Show, Eq, Ord)
398 deriving (Show, Eq, Ord)
399
399
400−-- | Given a links context, a thing to link to (either a value or a type), and
400+-- | Given a links context, the current module name, the namespace of a thing
401−-- its containing module, attempt to create a DocLink.
401+-- to link to, its title, and its containing module, attempt to create a
402+-- DocLink.
402getLink :: LinksContext -> P.ModuleName -> Namespace -> Text -> ContainingModule -> Maybe DocLink
403getLink :: LinksContext -> P.ModuleName -> Namespace -> Text -> ContainingModule -> Maybe DocLink
403getLink LinksContext{..} curMn namespace target containingMod = do
404getLink LinksContext{..} curMn namespace target containingMod = do
404 location <- getLinkLocation
405 location <- getLinkLocation
@@ -409,7 +410,7 @@ getLink LinksContext{..} curMn namespace target containingMod = do
409 }
410 }
410
411
411 where
412 where
412− getLinkLocation = normalLinkLocation <|> builtinLinkLocation
413+ getLinkLocation = builtinLinkLocation <|> normalLinkLocation
413
414
414 normalLinkLocation = do
415 normalLinkLocation = do
415 case containingMod of
416 case containingMod of
tests/TestDocs.hs+52−8
@@ -1,5 +1,6 @@
1{-# LANGUAGE RecordWildCards #-}
1{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE ViewPatterns #-}
2{-# LANGUAGE ViewPatterns #-}
3+{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE OverloadedStrings #-}
5
6
@@ -44,11 +45,12 @@ main = pushd "examples/docs" $ do
44 res <- Publish.preparePackage publishOpts
45 res <- Publish.preparePackage publishOpts
45 case res of
46 case res of
46 Left e -> Publish.printErrorToStdout e >> exitFailure
47 Left e -> Publish.printErrorToStdout e >> exitFailure
47− Right Docs.Package{..} ->
48+ Right pkg@Docs.Package{..} ->
48 forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) ->
49 forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) ->
49 let mdl = takeJust ("module not found in docs: " ++ T.unpack (P.runModuleName mn))
50 let mdl = takeJust ("module not found in docs: " ++ T.unpack (P.runModuleName mn))
50 (find ((==) mn . Docs.modName) pkgModules)
51 (find ((==) mn . Docs.modName) pkgModules)
52+ linksCtx = Docs.getLinksContext pkg
51− in forM_ pragmas (`runAssertionIO` mdl)
53+ in forM_ pragmas (\a -> runAssertionIO a linksCtx mdl)
52
54
53
55
54takeJust :: String -> Maybe a -> a
56takeJust :: String -> Maybe a -> a
@@ -82,6 +84,11 @@ data Assertion
82 -- | Assert that there should be some declarations re-exported from a
84 -- | Assert that there should be some declarations re-exported from a
83 -- particular module in a particular package.
85 -- particular module in a particular package.
84 | ShouldHaveReExport (Docs.InPackage P.ModuleName)
86 | ShouldHaveReExport (Docs.InPackage P.ModuleName)
87+ -- | Assert that a link to some specific declaration exists within the
88+ -- rendered code for a declaration. Fields are: local module, local
89+ -- declaration title, title of linked declaration, namespace of linked
90+ -- declaration, destination of link.
91+ | ShouldHaveLink P.ModuleName Text Text Docs.Namespace Docs.LinkLocation
85 deriving (Show)
92 deriving (Show)
86
93
87newtype ShowFn a = ShowFn a
94newtype ShowFn a = ShowFn a
@@ -119,6 +126,17 @@ data AssertionFailure
119 -- | A module was missing re-exports from a particular module.
126 -- | A module was missing re-exports from a particular module.
120 -- Fields: module name, expected re-export, actual re-exports.
127 -- Fields: module name, expected re-export, actual re-exports.
121 | ReExportMissing P.ModuleName (Docs.InPackage P.ModuleName) [Docs.InPackage P.ModuleName]
128 | ReExportMissing P.ModuleName (Docs.InPackage P.ModuleName) [Docs.InPackage P.ModuleName]
129+ -- | Expected to find some other declaration mentioned in this declaration's
130+ -- rendered code, but did not find anything.
131+ -- Fields: module name, declaration title, title of declaration which was
132+ -- expected but not found in.
133+ | LinkedDeclarationMissing P.ModuleName Text Text
134+ -- | Expected one link location for a declaration mentioned in some other
135+ -- declaration's rendered code, but found a different one. Fields: module
136+ -- name, title of the local declaration which links to some other
137+ -- declaration, title of the linked declaration, expected location, actual
138+ -- location.
139+ | BadLinkLocation P.ModuleName Text Text Docs.LinkLocation Docs.LinkLocation
122 deriving (Show)
140 deriving (Show)
123
141
124data AssertionResult
142data AssertionResult
@@ -126,8 +144,8 @@ data AssertionResult
126 | Fail AssertionFailure
144 | Fail AssertionFailure
127 deriving (Show)
145 deriving (Show)
128
146
129−runAssertion :: Assertion -> Docs.Module -> AssertionResult
147+runAssertion :: Assertion -> Docs.LinksContext -> Docs.Module -> AssertionResult
130−runAssertion assertion Docs.Module{..} =
148+runAssertion assertion linksCtx Docs.Module{..} =
131 case assertion of
149 case assertion of
132 ShouldBeDocumented mn decl children ->
150 ShouldBeDocumented mn decl children ->
133 case findChildren decl (declarationsFor mn) of
151 case findChildren decl (declarationsFor mn) of
@@ -214,6 +232,19 @@ runAssertion assertion Docs.Module{..} =
214 then Pass
232 then Pass
215 else Fail (ReExportMissing modName reExp reExps)
233 else Fail (ReExportMissing modName reExp reExps)
216
234
235+ ShouldHaveLink mn decl destTitle destNs expectedLoc ->
236+ findDecl mn decl $ \decl' ->
237+ let
238+ rendered = Docs.renderDeclaration decl'
239+ in
240+ case extract rendered destNs destTitle of
241+ Just (Docs.linkLocation -> actualLoc) ->
242+ if expectedLoc == actualLoc
243+ then Pass
244+ else Fail (BadLinkLocation mn decl destTitle expectedLoc actualLoc)
245+ Nothing ->
246+ Fail (LinkedDeclarationMissing mn decl destTitle)
247+
217 where
248 where
218 declarationsFor mn =
249 declarationsFor mn =
219 if mn == modName
250 if mn == modName
@@ -232,6 +263,17 @@ runAssertion assertion Docs.Module{..} =
232
263
233 childrenTitles = map Docs.cdeclTitle . Docs.declChildren
264 childrenTitles = map Docs.cdeclTitle . Docs.declChildren
234
265
266+ extract :: Docs.RenderedCode -> Docs.Namespace -> Text -> Maybe Docs.DocLink
267+ extract rc ns title = getFirst (Docs.outputWith (First . go) rc) >>= getLink
268+ where
269+ getLink =
270+ Docs.getLink linksCtx (P.moduleNameFromString "$DocsTest") ns title
271+ go = \case
272+ Docs.Symbol ns' title' (Docs.Link containingMod)
273+ | ns' == ns && title' == title -> Just containingMod
274+ _ ->
275+ Nothing
276+
235checkConstrained :: P.Type -> Text -> Bool
277checkConstrained :: P.Type -> Text -> Bool
236checkConstrained ty tyClass =
278checkConstrained ty tyClass =
237 -- Note that we don't recurse on ConstrainedType if none of the constraints
279 -- Note that we don't recurse on ConstrainedType if none of the constraints
@@ -248,10 +290,10 @@ checkConstrained ty tyClass =
248 matches className =
290 matches className =
249 (==) className . P.runProperName . P.disqualify . P.constraintClass
291 (==) className . P.runProperName . P.disqualify . P.constraintClass
250
292
251−runAssertionIO :: Assertion -> Docs.Module -> IO ()
293+runAssertionIO :: Assertion -> Docs.LinksContext -> Docs.Module -> IO ()
252−runAssertionIO assertion mdl = do
294+runAssertionIO assertion linksCtx mdl = do
253 putStrLn ("In " ++ T.unpack (P.runModuleName (Docs.modName mdl)) ++ ": " ++ show assertion)
295 putStrLn ("In " ++ T.unpack (P.runModuleName (Docs.modName mdl)) ++ ": " ++ show assertion)
254− case runAssertion assertion mdl of
296+ case runAssertion assertion linksCtx mdl of
255 Pass -> pure ()
297 Pass -> pure ()
256 Fail reason -> do
298 Fail reason -> do
257 putStrLn ("Failed: " <> show reason)
299 putStrLn ("Failed: " <> show reason)
@@ -276,6 +318,8 @@ testCases =
276 , ("Example2",
318 , ("Example2",
277 [ ShouldBeDocumented (n "Example2") "one" []
319 [ ShouldBeDocumented (n "Example2") "one" []
278 , ShouldBeDocumented (n "Example2") "two" []
320 , ShouldBeDocumented (n "Example2") "two" []
321+
322+ , ShouldHaveLink (n "Example2") "one" "Int" Docs.TypeLevel (Docs.BuiltinModule (n "Prim"))
279 ])
323 ])
280
324
281 , ("UTF8",
325 , ("UTF8",
@@ -359,7 +403,7 @@ testCases =
359 ]
403 ]
360
404
361 where
405 where
362− n = P.moduleNameFromString . T.pack
406+ n = P.moduleNameFromString
363 pkg str = let Right p = parsePackageName str in p
407 pkg str = let Right p = parsePackageName str in p
364
408
365 hasTypeVar varName =
409 hasTypeVar varName =