d6d3eb3 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Merge remote-tracking branch 'pure11/pure11' into native

commitd6d3eb398286efbf00533d263f30cfcdc023ae45 authorAndy Arvanitis <andyarvanitis@gmail.com> dateSun 12 Feb 2017, 21:01 (10 years ago) parente8f63d2 4e7cfee

4 files changed+80−56

compare with golang

unifiedsplit

purescript.cabal+1−1 src/Language/PureScript/CodeGen/JS.hs+23−44 src/Language/PureScript/Docs/Types.hs+4−3 tests/TestDocs.hs+52−8

purescript.cabal+1−1

@@ -1,5 +1,5 @@

11name: purescript

2−version: 0.10.6

2+version: 0.10.7

33cabal-version: >=1.8

44build-type: Simple

55license: BSD3

src/Language/PureScript/CodeGen/JS.hs+23−44

@@ -138,8 +138,8 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

138138 -- Generate code in the simplified Javascript intermediate representation for a declaration

139139 --

140140 bindToJs :: Bind Ann -> m [JS]

141− bindToJs (NonRec ann ident val) = nonRecToJS ann ident val

142− bindToJs (Rec vals) = concat <$> forM vals (uncurry . uncurry $ nonRecToJS)

141+ bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val

142+ bindToJs (Rec vals) = forM vals (uncurry . uncurry $ nonRecToJS)

143143

144144 -- |

145145 -- 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_ =

147147 --

148148 -- The main purpose of this function is to handle code generation for comments.

149149 --

150− nonRecToJS :: Ann -> Ident -> Expr Ann -> m [JS]

150+ nonRecToJS :: Ann -> Ident -> Expr Ann -> m JS

151151 nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do

152152 withoutComment <- asks optionsNoComments

153153 if withoutComment

154154 then nonRecToJS a i (modifyAnn removeComments e)

155− else withHead (JSComment Nothing com) <$> nonRecToJS a i (modifyAnn removeComments e)

156− where

157− withHead _ [] = []

158− withHead f (x:xs) = f x : xs

155+ else JSComment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e)

159156 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

165− return <$> (withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js))

157+ js <- valueToJs val

158+ withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js)

166159

167160 withPos :: Maybe SourceSpan -> JS -> m JS

168161 withPos (Just ss) js = do

@@ -258,37 +251,23 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

258251 JSObjectLiteral Nothing [("create",

259252 JSFunction Nothing Nothing ["value"]

260253 (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))])

261− 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 []))

277− , mkAccessor "value" $

278− JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (identToJs ident)) []

279− ]

280− fields ->

281− let constructor =

282− 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)

284− createFn =

285− 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

287− in [ constructor

288− , mkAccessor "create" createFn

289− ]

290− constructorToJs _ _ =

291− Nothing

254+ valueToJs' (Constructor _ _ (ProperName ctor) []) =

255+ return $ iife (properToJs ctor) [ JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing [])

256+ , JSAssignment Nothing (accessorString "value" (JSVar Nothing (properToJs ctor)))

257+ (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) []) ]

258+ valueToJs' (Constructor _ _ (ProperName ctor) fields) =

259+ let constructor =

260+ let body = [ JSAssignment Nothing ((accessorString $ mkString $ identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]

261+ in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body)

262+ createFn =

263+ let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields)

264+ in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields

265+ in return $ iife (properToJs ctor) [ constructor

266+ , JSAssignment Nothing (accessorString "create" (JSVar Nothing (properToJs ctor))) createFn

267+ ]

268+

269+ iife :: Text -> [JS] -> JS

270+ iife v exprs = JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing $ exprs ++ [JSReturn Nothing $ JSVar Nothing v])) []

292271

293272 literalToValueJS :: Literal (Expr Ann) -> m JS

294273 literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i)

src/Language/PureScript/Docs/Types.hs+4−3

@@ -397,8 +397,9 @@ data LinkLocation

397397 | BuiltinModule P.ModuleName

398398 deriving (Show, Eq, Ord)

399399

400−-- | Given a links context, a thing to link to (either a value or a type), and

401−-- its containing module, attempt to create a DocLink.

400+-- | Given a links context, the current module name, the namespace of a thing

401+-- to link to, its title, and its containing module, attempt to create a

402+-- DocLink.

402403getLink :: LinksContext -> P.ModuleName -> Namespace -> Text -> ContainingModule -> Maybe DocLink

403404getLink LinksContext{..} curMn namespace target containingMod = do

404405 location <- getLinkLocation

@@ -409,7 +410,7 @@ getLink LinksContext{..} curMn namespace target containingMod = do

409410 }

410411

411412 where

412− getLinkLocation = normalLinkLocation <|> builtinLinkLocation

413+ getLinkLocation = builtinLinkLocation <|> normalLinkLocation

413414

414415 normalLinkLocation = do

415416 case containingMod of

tests/TestDocs.hs+52−8

@@ -1,5 +1,6 @@

11{-# LANGUAGE RecordWildCards #-}

22{-# LANGUAGE ViewPatterns #-}

3+{-# LANGUAGE LambdaCase #-}

34{-# LANGUAGE DataKinds #-}

45{-# LANGUAGE OverloadedStrings #-}

@@ -44,11 +45,12 @@ main = pushd "examples/docs" $ do

4445 res <- Publish.preparePackage publishOpts

4546 case res of

4647 Left e -> Publish.printErrorToStdout e >> exitFailure

47− Right Docs.Package{..} ->

48+ Right pkg@Docs.Package{..} ->

4849 forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) ->

4950 let mdl = takeJust ("module not found in docs: " ++ T.unpack (P.runModuleName mn))

5051 (find ((==) mn . Docs.modName) pkgModules)

51− in forM_ pragmas (`runAssertionIO` mdl)

52+ linksCtx = Docs.getLinksContext pkg

53+ in forM_ pragmas (\a -> runAssertionIO a linksCtx mdl)

5254

5355

5456takeJust :: String -> Maybe a -> a

@@ -82,6 +84,11 @@ data Assertion

8284 -- | Assert that there should be some declarations re-exported from a

8385 -- particular module in a particular package.

8486 | 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

8592 deriving (Show)

8693

8794newtype ShowFn a = ShowFn a

@@ -119,6 +126,17 @@ data AssertionFailure

119126 -- | A module was missing re-exports from a particular module.

120127 -- Fields: module name, expected re-export, actual re-exports.

121128 | 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

122140 deriving (Show)

123141

124142data AssertionResult

@@ -126,8 +144,8 @@ data AssertionResult

126144 | Fail AssertionFailure

127145 deriving (Show)

128146

129−runAssertion :: Assertion -> Docs.Module -> AssertionResult

130−runAssertion assertion Docs.Module{..} =

147+runAssertion :: Assertion -> Docs.LinksContext -> Docs.Module -> AssertionResult

148+runAssertion assertion linksCtx Docs.Module{..} =

131149 case assertion of

132150 ShouldBeDocumented mn decl children ->

133151 case findChildren decl (declarationsFor mn) of

@@ -214,6 +232,19 @@ runAssertion assertion Docs.Module{..} =

214232 then Pass

215233 else Fail (ReExportMissing modName reExp reExps)

216234

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+

217248 where

218249 declarationsFor mn =

219250 if mn == modName

@@ -232,6 +263,17 @@ runAssertion assertion Docs.Module{..} =

232263

233264 childrenTitles = map Docs.cdeclTitle . Docs.declChildren

234265

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+

235277checkConstrained :: P.Type -> Text -> Bool

236278checkConstrained ty tyClass =

237279 -- Note that we don't recurse on ConstrainedType if none of the constraints

@@ -248,10 +290,10 @@ checkConstrained ty tyClass =

248290 matches className =

249291 (==) className . P.runProperName . P.disqualify . P.constraintClass

250292

251−runAssertionIO :: Assertion -> Docs.Module -> IO ()

252−runAssertionIO assertion mdl = do

293+runAssertionIO :: Assertion -> Docs.LinksContext -> Docs.Module -> IO ()

294+runAssertionIO assertion linksCtx mdl = do

253295 putStrLn ("In " ++ T.unpack (P.runModuleName (Docs.modName mdl)) ++ ": " ++ show assertion)

254− case runAssertion assertion mdl of

296+ case runAssertion assertion linksCtx mdl of

255297 Pass -> pure ()

256298 Fail reason -> do

257299 putStrLn ("Failed: " <> show reason)

@@ -276,6 +318,8 @@ testCases =

276318 , ("Example2",

277319 [ ShouldBeDocumented (n "Example2") "one" []

278320 , ShouldBeDocumented (n "Example2") "two" []

321+

322+ , ShouldHaveLink (n "Example2") "one" "Int" Docs.TypeLevel (Docs.BuiltinModule (n "Prim"))

279323 ])

280324

281325 , ("UTF8",

@@ -359,7 +403,7 @@ testCases =

359403 ]

360404

361405 where

362− n = P.moduleNameFromString . T.pack

406+ n = P.moduleNameFromString

363407 pkg str = let Right p = parsePackageName str in p

364408

365409 hasTypeVar varName =