62bd942 · rowtype-yoga/purescript-docs-search

git.iko.soy/rowtype-yoga/purescript-docs-search

a bunch of improvements

commit62bd942bf0f0025b380368f8f6d61beca4a811ba authorklntsky <klntsky@gmail.com> dateFri 28 Jun 2019, 23:15 (7 years ago) parentf354ade

11 files changed+519−163

compare with master

unifiedsplit

src/Spago/Search/App.purs+3 src/Spago/Search/App/SearchField.purs+15−1 src/Spago/Search/App/SearchResults.purs+294−102 src/Spago/Search/Extra.purs+6 src/Spago/Search/Index.purs+42−28 src/Spago/Search/IndexBuilder.purs+7−2 src/Spago/Search/TypeQuery.purs+14−10 src/Spago/Search/TypeShape.purs+15−8 test/Main.purs+12−5 test/Test/TypeQuery.purs+21−7 test/Test/TypeShape.purs+90

src/Spago/Search/App.purs+3

@@ -61,6 +61,9 @@ insertStyle doc = do

6161 .result {

6262 font-size: 1.25em;

6363 }

64+ .result__body .keyword, .result__body .syntax {

65+ color: #0B71B4;

66+ }

6467 """

6568 mbHead <-

6669 ParentNode.querySelector (wrap "head") (Document.toParentNode doc)

src/Spago/Search/App/SearchField.purs+15−1

@@ -10,15 +10,19 @@ import Halogen.HTML as HH

1010import Halogen.HTML.CSS as HS

1111import Halogen.HTML.Events as HE

1212import Halogen.HTML.Properties as HP

13+import Web.UIEvent.KeyboardEvent as KeyboardEvent

1314

1415type State = { input :: String }

1516

1617data Action

1718 = InputAction String

19+ | EnterPressed

20+ | EscapePressed

1821 | FocusChanged Boolean

1922

2023data Message

2124 = InputUpdated String

25+ | InputCleared

2226 | Focused

2327 | LostFocus

2428

@@ -37,7 +41,12 @@ handleAction :: forall m. Action -> H.HalogenM State Action () Message m Unit

3741handleAction = case _ of

3842 InputAction input -> do

3943 H.modify_ $ const { input }

40− H.raise $ InputUpdated input

44+ EnterPressed -> do

45+ state <- H.get

46+ H.raise $ InputUpdated state.input

47+ EscapePressed -> do

48+ H.modify_ (_ { input = "" })

49+ H.raise $ InputCleared

4150 FocusChanged status -> do

4251 H.raise

4352 if status

@@ -60,6 +69,11 @@ render state =

6069 [ HP.value state.input

6170 , HP.placeholder "Search for definitions"

6271 , HP.type_ HP.InputText

72+ , HE.onKeyUp (\event ->

73+ case KeyboardEvent.code event of

74+ "Enter" -> Just EnterPressed

75+ "Escape" -> Just EscapePressed

76+ _ -> Nothing)

6377 , HE.onValueInput (Just <<< InputAction)

6478 , HE.onFocusIn $ const $ Just $ FocusChanged true

6579 , HE.onFocusOut $ const $ Just $ FocusChanged false

src/Spago/Search/App/SearchResults.purs+294−102

@@ -4,14 +4,15 @@ import Prelude

55import Spago.Search.Index

66import Spago.Search.TypeDecoder

7−import Spago.Search.TypeShape

87import Spago.Search.TypeQuery

8+import Spago.Search.TypeShape

1010import CSS (textWhitespace, whitespacePreWrap)

11+import Data.Array ((!!))

1112import Data.Array as Array

1213import Data.Either (Either(..))

1314import Data.List as List

14−import Data.Maybe (Maybe(..), isNothing, isJust)

15+import Data.Maybe (Maybe(..), isJust, isNothing)

1516import Data.Newtype (unwrap, wrap)

1617import Data.Search.Trie as Trie

1718import Data.String (length) as String

@@ -27,14 +28,16 @@ import Halogen.HTML.Events as HE

2728import Halogen.HTML.Properties as HP

2829import Spago.Search.App.SearchField (Message(..))

2930import Spago.Search.DocsJson (loadDeclarations)

30−import Spago.Search.Extra (whenJust)

31+import Spago.Search.Extra (whenJust, (>#>))

3132import Web.DOM.Element (Element)

3233import Web.DOM.Element as Element

3334import Web.HTML as HTML

3435import Web.HTML.Location as Location

3536import Web.HTML.Window as Window

3637

37−-- | Is it a search by type or by declaration?

38+data Mode = Off | Loading | Active

39+

40+-- | Is it a search by type or by name?

3841data ResultsType = TypeResults TypeQuery | DeclResults

3942

4043type State = { mbIndex :: Maybe SearchIndex

@@ -43,6 +46,7 @@ type State = { mbIndex :: Maybe SearchIndex

4346 , input :: String

4447 , contents :: Element

4548 , resultsCount :: Int

49+ , mode :: Mode

4650 }

4751

4852data Query a

@@ -50,9 +54,12 @@ data Query a

5054

5155data Action

5256 = SearchResultClicked String

53− | ShowMore

57+ | MoreResultsRequested

5458

55−mkComponent :: forall o i. Element -> H.Component HH.HTML Query i o Aff

59+mkComponent

60+ :: forall o i

61+ . Element

62+ -> H.Component HH.HTML Query i o Aff

5663mkComponent contents =

5764 H.mkComponent

5865 { initialState: const { mbIndex: Nothing

@@ -61,46 +68,66 @@ mkComponent contents =

6168 , input: ""

6269 , contents

6370 , resultsCount: 25

71+ , mode: Off

6472 }

6573 , render

6674 , eval: H.mkEval $ H.defaultEval { handleQuery = handleQuery

6775 , handleAction = handleAction }

6876 }

6977

70−handleQuery :: forall o a. Query a -> H.HalogenM State Action () o Aff (Maybe a)

78+handleQuery

79+ :: forall o a

80+ . Query a

81+ -> H.HalogenM State Action () o Aff (Maybe a)

7182handleQuery (SearchFieldMessage Focused next) = do

72− state <- H.get

73− when (isNothing state.mbIndex) do

74− eiDeclarations <- H.liftAff $ loadDeclarations "../spago-search-index.js"

83+ pure Nothing

84+handleQuery (SearchFieldMessage LostFocus next) = do

85+ pure Nothing

86+handleQuery (SearchFieldMessage InputCleared next) = do

87+ H.modify_ (_ { results = [], input = "", mode = Off })

88+ showPageContents

89+ pure Nothing

90+handleQuery (SearchFieldMessage (InputUpdated input) next) = do

91+ H.modify_ (_ { input = input })

92+

93+ H.get >>= \state -> when (isNothing state.mbIndex) do

94+ H.modify_ (_ { mode = Loading })

95+ eiDeclarations <-

96+ H.liftAff $ loadDeclarations "../spago-search-index.js"

7597 case eiDeclarations of

7698 Left err -> do

7799 H.liftEffect do

78100 error $ "spago-search: couldn't load search index: " <> err

79101 Right declarations -> do

80102 H.modify_ (_ { mbIndex = Just $ mkSearchIndex declarations })

81− pure Nothing

82−handleQuery (SearchFieldMessage LostFocus next) = do

83− pure Nothing

84−handleQuery (SearchFieldMessage (InputUpdated input) next) = do

85− H.modify_ (_ { input = input })

103+

104+ H.modify_ (_ { mode = Active })

105+

86106 if String.length input < 2

87107 then do

108+

88109 showPageContents

89110 H.modify_ (_ { results = [] })

111+

90112 else do

113+

91114 hidePageContents

92115 state <- H.get

116+

93117 whenJust (unwrap <$> state.mbIndex) \index -> do

94118 let path = List.fromFoldable $

95119 String.toCharArray $

96120 String.toLower input

121+

97122 eiTypeQuery = parseTypeQuery input

123+

98124 resultsType =

99125 case eiTypeQuery of

100126 Left _ -> DeclResults

101127 Right query

102− | isValuableQuery query -> TypeResults query

128+ | isValuableTypeQuery query -> TypeResults query

103129 | otherwise -> DeclResults

130+

104131 results =

105132 case resultsType of

106133 DeclResults ->

@@ -111,18 +138,24 @@ handleQuery (SearchFieldMessage (InputUpdated input) next) = do

111138 index.decls

112139 TypeResults query ->

113140 List.toUnfoldable $

114− Trie.queryValues shape index.types >>= identity

141+ join $

142+ Trie.queryValues shape index.types

115143 where

116144 shape = shapeOfTypeQuery query

145+

117146 H.modify_ (_ { results = results

118147 , resultsType = resultsType

119148 , resultsCount = 25 })

120149 pure Nothing

121150

122−handleAction :: forall o. Action -> H.HalogenM State Action () o Aff Unit

151+handleAction

152+ :: forall o

153+ . Action

154+ -> H.HalogenM State Action () o Aff Unit

123155handleAction = case _ of

124− ShowMore -> do

156+ MoreResultsRequested -> do

125157 H.modify_ (\state -> state { resultsCount = state.resultsCount + 25 })

158+

126159 SearchResultClicked moduleName -> do

127160 -- Decide if we are going to load a new page or to jump to a hash on the

128161 -- current page. In the latter case, hide search results and show the main

@@ -138,23 +171,32 @@ handleAction = case _ of

138171 showPageContents

139172 H.modify_ (_ { input = "" })

140173

141−showPageContents :: forall o. H.HalogenM State Action () o Aff Unit

174+showPageContents

175+ :: forall o

176+ . H.HalogenM State Action () o Aff Unit

142177showPageContents = do

143178 state <- H.get

144179 H.liftEffect do

145180 Element.removeAttribute "style" state.contents

146181

147−hidePageContents :: forall o. H.HalogenM State Action () o Aff Unit

182+hidePageContents

183+ :: forall o

184+ . H.HalogenM State Action () o Aff Unit

148185hidePageContents = do

149186 state <- H.get

150187 H.liftEffect do

151188 Element.setAttribute "style" "display: none" state.contents

152189

153−render :: forall m. State -> H.ComponentHTML Action () m

154−render { mbIndex: Nothing } =

155− HH.div_ []

156−render { input: "" } =

157− HH.div_ []

190+render

191+ :: forall m

192+ . State

193+ -> H.ComponentHTML Action () m

194+render { mbIndex: Nothing, mode: Loading } =

195+ HH.div [ HP.classes [ wrap "container", wrap "clearfix" ] ] $

196+ pure $

197+ HH.div [ HP.classes [ wrap "col", wrap "col--main" ] ] $

198+ [ HH.h1_ [ HH.text "Loading..." ] ]

199+

158200render state =

159201 HH.div [ HP.classes [ wrap "container", wrap "clearfix" ] ] $

160202 pure $

@@ -188,20 +230,25 @@ render state =

188230 , HH.div [ HP.class_ (wrap "load_more"), HP.id_ "load-more" ]

189231 [ if Array.length selectedResults < Array.length state.results

190232 then HH.a [ HP.id_ "load-more-link"

191− , HE.onClick $ const $ Just ShowMore ]

233+ , HE.onClick $ const $ Just MoreResultsRequested ]

192234 [ HH.text "Show more results" ]

193235 else HH.p_

194236 [ HH.text "No further results." ]

195237 ]

196238 ]

197239

198−renderSummary :: forall a b. String -> HH.HTML b a

240+renderSummary

241+ :: forall a b

242+ . String

243+ -> HH.HTML b a

199244renderSummary text =

200245 HH.div [ HP.id_ "spago-search-summary" ]

201− [ HH.text text

202− ]

246+ [ HH.text text ]

203247

204−renderResult :: forall a. SearchResult -> Array (HH.HTML a Action)

248+renderResult

249+ :: forall a

250+ . SearchResult

251+ -> Array (HH.HTML a Action)

205252renderResult = unwrap >>> \result ->

206253 [ HH.div [ HP.class_ (wrap "result") ]

207254 [ HH.h3 [ HP.class_ (wrap "result__title") ]

@@ -218,22 +265,21 @@ renderResult = unwrap >>> \result ->

218265 , HH.div [ HP.class_ (wrap "result__body") ] $

219266 renderResultType result <>

220267

221− case result.comments of

222− Just comments -> [ HH.pre [ HS.style do

223− textWhitespace whitespacePreWrap ]

224− [ HH.text comments ]

225− ]

226− Nothing -> [ ]

268+ result.comments >#>

269+ \comments -> [ HH.pre [ HS.style do

270+ textWhitespace whitespacePreWrap ]

271+ [ HH.text comments ]

272+ ]

227273

228274 , HH.div [ HP.class_ (wrap "result__actions") ]

275+

229276 [ HH.span [ HP.class_ (wrap "result__actions__item") ]

230277 [ HH.span [ HP.classes [ wrap "badge"

231278 , wrap "badge--package"

232279 ]

233280 , HP.title "Package"

234281 ]

235− [ HH.text "P"

236− ]

282+ [ HH.text "P" ]

237283 , HH.text result.packageName

238284 ]

239285

@@ -243,8 +289,7 @@ renderResult = unwrap >>> \result ->

243289 ]

244290 , HP.title "Module"

245291 ]

246− [ HH.text "M"

247− ]

292+ [ HH.text "M" ]

248293 , HH.text result.moduleName

249294 ]

250295 ]

@@ -254,42 +299,115 @@ renderResultType

254299 :: forall a rest

255300 . { info :: ResultInfo

256301 , name :: String

302+ , moduleName :: String

257303 | rest

258304 }

259305 -> Array (HH.HTML a Action)

260−renderResultType = \result ->

306+renderResultType result =

261307 case result.info of

262− ValueResult {type:ty} ->

263− [ HH.pre [ HP.class_ (wrap "result__signature") ]

264− [ HH.code_ [ HH.text (result.name <> " :: ")

265− , renderType ty ]

266− ]

267− ]

308+ ValueResult { type: ty } ->

309+ wrapSignature [ HH.a [ makeHref ValueLevel false result.moduleName result.name ]

310+ [ HH.text result.name ]

311+ , HH.text " :: "

312+ , renderType ty ]

313+

314+ TypeClassMemberResult info ->

315+ wrapSignature $ renderTypeClassMemberSignature info result

316+

317+ TypeClassResult info ->

318+ wrapSignature $ renderTypeClassResult info result

268319 _ -> []

320+ where

321+ wrapSignature signature =

322+ [ HH.pre [ HP.class_ (wrap "result__signature") ] [ HH.code_ signature ] ]

269323

270−renderType :: forall a. Type -> HH.HTML a Action

324+renderTypeClassResult

325+ :: forall a rest

326+ . { fundeps :: FunDeps

327+ , arguments :: Array TypeArgument

328+ , superclasses :: Array Constraint

329+ }

330+ -> { name :: String, moduleName :: String | rest }

331+ -> Array (HH.HTML a Action)

332+renderTypeClassResult { fundeps, arguments, superclasses } { name, moduleName } =

333+ [ keyword "class"

334+ , if Array.null superclasses

335+ then

336+ HH.text ""

337+ else

338+ HH.span_ $

339+ [ syntax " ("

340+ , HH.span_ $ Array.intercalate [ HH.text ", " ] (

341+ superclasses <#> renderConstraint >>> Array.singleton

342+ )

343+ , syntax ")"

344+ , HH.text " "

345+ , syntax "<="

346+ ]

347+ , HH.text " "

348+ , HH.a [ makeHref TypeLevel false moduleName name ]

349+ [ HH.text name ]

350+ , HH.text " "

351+ ] <> (

352+ Array.intercalate [ HH.text " " ] (

353+ arguments <#> (

354+ unwrap >>>

355+ \argument ->

356+ case argument.mbKind of

357+ Nothing ->

358+ [ HH.text argument.name ]

359+ Just kind ->

360+ [ HH.text "("

361+ , HH.text argument.name

362+ , HH.text " :: "

363+ , renderKind kind

364+ , HH.text ")"

365+ ]))

366+ )

367+

368+-- | Insert type class name and arguments

369+renderTypeClassMemberSignature

370+ :: forall a rest

371+ . { type :: Type

372+ , typeClass :: String

373+ , typeClassArguments :: Array String

374+ }

375+ -> { name :: String | rest }

376+ -> Array (HH.HTML a Action)

377+renderTypeClassMemberSignature { type: ty, typeClass, typeClassArguments } result =

378+ [ HH.text result.name

379+ , HH.text " :: "

380+ , HH.text $ typeClass <> " "

381+ -- We don't want to insert `forall` here to avoid visual noise,

382+ -- and to make type class members more easily distinguishable from ordinary values.

383+ -- TODO: consider doing what pursuit does.

384+ , HH.text $ Array.intercalate " " typeClassArguments <> " "

385+ , HH.text "=> "

386+ , renderType ty ]

387+

388+renderType

389+ :: forall a

390+ . Type

391+ -> HH.HTML a Action

271392renderType = case _ of

272393 TypeVar str -> HH.text str

273− TypeLevelString str -> HH.text str

394+ TypeLevelString str -> HH.text $ "(Text \"" <> str <> "\")" -- TODO: add escaping

274395 TypeWildcard -> HH.text "_"

275− TypeConstructor qname -> renderQualifiedName qname

276− TypeOp qname -> renderQualifiedName qname

396+ TypeConstructor qname -> renderQualifiedName false TypeLevel qname

397+ TypeOp qname -> renderQualifiedName true TypeLevel qname

277398

278399 TypeApp (TypeApp (TypeConstructor

279− (QualifiedName { moduleName: ["Prim"]

400+ (QualifiedName { moduleName: [ "Prim" ]

280401 , name: "Function" })) t1) t2 ->

281402 HH.span_ [ renderType t1

282403 , HH.text " -> "

283404 , renderType t2

284405 ]

285406

286− TypeApp (TypeConstructor (QualifiedName { moduleName: ["Prim"]

407+ TypeApp (TypeConstructor (QualifiedName { moduleName: [ "Prim" ]

287408 , name: "Record" }))

288− record ->

289− HH.span_ [ HH.text "{ | "

290− , renderType record

291− , HH.text " }" ]

292−

409+ row ->

410+ renderRow false row

293411

294412 TypeApp t1 t2 ->

295413 HH.span_ [ renderType t1

@@ -298,20 +416,7 @@ renderType = case _ of

298416 ]

299417

300418 ty@(ForAll _ _ _) ->

301− let foralls = joinForAlls ty in

302− HH.span_ $

303− [ HH.text "forall" ] <>

304− ( Array.fromFoldable foralls.binders <#>

305− \ { var, mbKind } ->

306− case mbKind of

307− Nothing -> HH.text (" " <> var)

308− Just kind ->

309− HH.span_ [ HH.text ("(" <> var <> " :: ")

310− , renderKind kind

311− , HH.text ")"

312− ]

313− ) <>

314− [ HH.text ". ", renderType foralls.ty ]

419+ renderForAll ty

315420

316421 ConstrainedType cnstr ty ->

317422 HH.span_

@@ -320,15 +425,18 @@ renderType = case _ of

320425 , renderType ty

321426 ]

322427

323− REmpty -> HH.text "{}"

324− ty@(RCons _ _ _) -> renderRow ty

428+ ty@REmpty -> renderRow true ty

429+ ty@(RCons _ _ _) -> renderRow true ty

325430

326431 BinaryNoParensType op t1 t2 ->

327432 HH.span_

328433 [ renderType t1

434+ , HH.text " "

329435 , renderType op

436+ , HH.text " "

330437 , renderType t2

331438 ]

439+

332440 ParensInType ty ->

333441 HH.span_

334442 [ HH.text "("

@@ -336,39 +444,123 @@ renderType = case _ of

336444 , HH.text ")"

337445 ]

338446

339−renderRow :: forall a. Type -> HH.HTML a Action

340−renderRow ty =

341− let rows = joinRows ty in

447+renderForAll

448+ :: forall a

449+ . Type

450+ -> HH.HTML a Action

451+renderForAll ty =

342452 HH.span_ $

343− [ HH.text "{ " ] <>

344− ( Array.intercalate [ HH.text ", " ] $ Array.fromFoldable rows <#>

345− \entry ->

346− [ HH.span_ [ HH.text $ entry.row <> " :: "

347− , renderType entry.ty ] ]

453+

454+ [ HH.text "forall" ] <>

455+

456+ ( Array.fromFoldable foralls.binders <#>

457+ \ { var, mbKind } ->

458+ case mbKind of

459+ Nothing -> HH.text (" " <> var)

460+ Just kind ->

461+ HH.span_ [ HH.text $ " (" <> var <> " :: "

462+ , renderKind kind

463+ , HH.text ")" ]

348464 ) <>

349− [ HH.text " }" ]

350465

351−htmlSingleton :: forall t406 t407. HH.HTML t407 t406 -> HH.HTML t407 t406

352−htmlSingleton x = HH.span_ [ x ]

466+ [ HH.text ". ", renderType foralls.ty ]

467+

468+ where

469+ foralls = joinForAlls ty

470+

471+renderRow

472+ :: forall a

473+ . Boolean

474+ -> Type

475+ -> HH.HTML a Action

476+renderRow asRow =

477+ joinRows >>> \ { rows, ty } ->

353478

354−renderConstraint :: forall a. Constraint -> HH.HTML a Action

355−renderConstraint (Constraint { constraintClass, constraintArgs }) =

356479 HH.span_ $

357− [ renderQualifiedName constraintClass, HH.text " " ] <>

358− Array.intercalate [ HH.text " " ] (constraintArgs <#> \ty -> [ renderType ty ])

359480

481+ if List.null rows

482+ then

483+ [ HH.text $ if asRow then "()" else "{}" ]

484+ else

485+ [ HH.text opening ] <>

486+

487+ ( Array.intercalate [ HH.text ", " ] $ Array.fromFoldable $ rows <#>

488+ \entry ->

489+ [ HH.span_ [ HH.text $ entry.row <> " :: "

490+ , renderType entry.ty ] ]

491+ ) <>

492+

493+ case ty of

494+ Just ty' -> [ HH.text " | ", renderType ty', HH.text closing ]

495+ Nothing -> [ HH.text closing ]

496+

497+ where

498+ opening = if asRow then "( " else "{ "

499+ closing = if asRow then " )" else " }"

360500

361−renderQualifiedName :: forall a. QualifiedName -> HH.HTML a Action

362−renderQualifiedName (QualifiedName { moduleName, name })

363− = HH.text name

501+renderConstraint

502+ :: forall a

503+ . Constraint

504+ -> HH.HTML a Action

505+renderConstraint (Constraint { constraintClass, constraintArgs }) =

506+ HH.span_ $

507+ [ renderQualifiedName false TypeLevel constraintClass, HH.text " " ] <>

508+ Array.intercalate [ HH.text " " ] (constraintArgs <#> \ty -> [ renderType ty ])

364509

365−renderKind :: forall a. Kind -> HH.HTML a Action

510+renderQualifiedName

511+ :: forall a

512+ . Boolean

513+ -> DeclLevel

514+ -> QualifiedName

515+ -> HH.HTML a Action

516+renderQualifiedName isInfix level (QualifiedName { moduleName, name })

517+ = if isBuiltIn then

518+ HH.text name

519+ else

520+ HH.a [ HE.onClick $ const $ Just $

521+ SearchResultClicked $ moduleNameString

522+ , makeHref level isInfix moduleNameString name

523+ ]

524+ [ HH.text name ]

525+ where

526+ moduleNameString = Array.intercalate "." moduleName

527+ isBuiltIn = moduleName !! 0 == Just "Prim"

528+

529+renderKind

530+ :: forall a

531+ . Kind ->

532+ HH.HTML a Action

366533renderKind = case _ of

367− Row k1 -> HH.span_ [ HH.text "#", renderKind k1 ]

368− FunKind k1 k2 -> HH.span_ [ renderKind k1, renderKind k2 ]

369− NamedKind qname -> renderQualifiedName qname

370−

371−isValuableQuery :: TypeQuery -> Boolean

372−isValuableQuery (QVar _) = false

373−isValuableQuery (QConst _) = false

374−isValuableQuery _ = true

534+ Row k1 -> HH.span_ [ HH.text "# ", renderKind k1 ]

535+ FunKind k1 k2 -> HH.span_ [ renderKind k1, HH.text " -> ", renderKind k2 ]

536+ NamedKind qname -> renderQualifiedName false KindLevel qname

537+

538+makeHref

539+ :: forall t rest

540+ . DeclLevel

541+ -> Boolean

542+ -> String

543+ -> String

544+ -> HH.IProp ( href :: String | rest ) t

545+makeHref level isInfix moduleName name =

546+ HP.href $

547+ moduleName <> ".html#" <>

548+ declLevelToHashAnchor level <> ":" <>

549+ if isInfix then "type (" <> name <> ")" else name

550+

551+keyword

552+ :: forall a

553+ . String

554+ -> HH.HTML a Action

555+keyword str = HH.span [ HP.class_ (wrap "keyword") ] [ HH.text str ]

556+

557+syntax

558+ :: forall a

559+ . String

560+ -> HH.HTML a Action

561+syntax str = HH.span [ HP.class_ (wrap "syntax") ] [ HH.text str ]

562+

563+isValuableTypeQuery :: TypeQuery -> Boolean

564+isValuableTypeQuery (QVar _) = false

565+isValuableTypeQuery (QConst _) = false

566+isValuableTypeQuery _ = true

src/Spago/Search/Extra.purs+6

@@ -2,8 +2,14 @@ module Spago.Search.Extra where

33import Prelude

5+import Data.Foldable (class Foldable, foldMap)

56import Data.Maybe (Maybe(..))

78whenJust :: forall a m. Monad m => Maybe a -> (a -> m Unit) -> m Unit

89whenJust (Just a) f = f a

910whenJust _ _ = pure unit

11+

12+foldMapFlipped :: forall a m f. Foldable f => Monoid m => f a -> (a -> m) -> m

13+foldMapFlipped = flip foldMap

14+

15+infixr 7 foldMapFlipped as >#>

src/Spago/Search/Index.purs+42−28

@@ -11,7 +11,7 @@ import Data.List (List, (:))

1111import Data.List as List

1212import Data.Maybe (Maybe(..), fromMaybe)

1313import Data.Newtype (class Newtype, unwrap)

14−import Data.Search.Trie (Trie, alter, entriesUnordered, fromList, insert)

14+import Data.Search.Trie (Trie, alter, entriesUnordered)

1515import Data.String.CodeUnits (stripPrefix, stripSuffix, toCharArray)

1616import Data.String.Common (toLower)

1717import Data.String.Common as String

@@ -31,7 +31,9 @@ data ResultInfo

3131 | ExternDataResult { kind :: Kind }

3232 | TypeSynonymResult { type :: Type }

3333 | DataConstructorResult { arguments :: Array Type }

34− | TypeClassMemberResult { type :: Type }

34+ | TypeClassMemberResult { type :: Type

35+ , typeClass :: String

36+ , typeClassArguments :: Array String }

3537 | TypeClassResult { fundeps :: FunDeps

3638 , arguments :: Array TypeArgument

3739 , superclasses :: Array Constraint }

@@ -131,27 +133,30 @@ resultsForEntry

131133 -> List { path :: String

132134 , result :: SearchResult

133135 }

134−resultsForEntry moduleName ie@(IndexEntry entry@{info, title, sourceSpan, comments, children}) =

135− let { name, declLevel } = getLevelAndName info.declType title

136+resultsForEntry moduleName indexEntry@(IndexEntry entry) =

137+ let { info, title, sourceSpan, comments, children } = entry

138+ { name, declLevel } = getLevelAndName info.declType title

136139 packageName = extractPackageName sourceSpan.name

137− in case mkInfo declLevel ie of

140+ in case mkInfo declLevel indexEntry of

138141 Nothing -> mempty

139− Just info' -> (

140− List.singleton $

141− { path: name

142− , result: SearchResult { name: title

143− , comments

144− , hashAnchor: declLevelToHashAnchor declLevel

145− , moduleName

146− , sourceSpan: Just sourceSpan

147− , packageName

148− , info: info'

149− }

150− }

151− ) <>

152− ( List.fromFoldable children >>=

153− resultsForChildIndexEntry packageName moduleName

154− )

142+ Just info' ->

143+ let result = SearchResult { name: title

144+ , comments

145+ , hashAnchor: declLevelToHashAnchor declLevel

146+ , moduleName

147+ , sourceSpan: Just sourceSpan

148+ , packageName

149+ , info: info'

150+ }

151+ in

152+ ( List.singleton $

153+ { path: name

154+ , result

155+ }

156+ ) <>

157+ ( List.fromFoldable children >>=

158+ resultsForChildIndexEntry packageName moduleName result

159+ )

155160

156161mkInfo :: DeclLevel -> IndexEntry -> Maybe ResultInfo

157162mkInfo declLevel (IndexEntry { info, title }) =

@@ -240,11 +245,12 @@ extractPackageName name =

240245resultsForChildIndexEntry

241246 :: String

242247 -> String

248+ -> SearchResult

243249 -> ChildIndexEntry

244250 -> List { path :: String, result :: SearchResult }

245−resultsForChildIndexEntry packageName moduleName

246− cie@(ChildIndexEntry { title, info, comments, mbSourceSpan }) =

247− case mkChildInfo cie of

251+resultsForChildIndexEntry packageName moduleName parentResult

252+ child@(ChildIndexEntry { title, info, comments, mbSourceSpan }) =

253+ case mkChildInfo parentResult child of

248254 Nothing -> mempty

249255 Just resultInfo ->

250256 { path: title

@@ -258,13 +264,21 @@ resultsForChildIndexEntry packageName moduleName

258264 }

259265 } # List.singleton

260266

261−mkChildInfo :: ChildIndexEntry -> Maybe ResultInfo

262−mkChildInfo (ChildIndexEntry { info } ) =

267+mkChildInfo :: SearchResult -> ChildIndexEntry -> Maybe ResultInfo

268+mkChildInfo parentResult (ChildIndexEntry { info } ) =

263269 case info.declType of

264270 ChildDeclDataConstructor ->

265271 info.arguments <#>

266272 \arguments -> DataConstructorResult { arguments }

267273 ChildDeclTypeClassMember ->

268− info.type <#>

269− \ty -> TypeClassMemberResult { type: ty }

274+ -- We need to get the name and the type arguments of a parent class.

275+ case (unwrap parentResult).info of

276+ TypeClassResult { arguments } ->

277+ info.type <#>

278+ \ty -> TypeClassMemberResult

279+ { type: ty

280+ , typeClass: (unwrap parentResult).name

281+ , typeClassArguments: arguments <#> unwrap >>> (_.name)

282+ }

283+ _ -> Nothing

270284 ChildDeclInstance -> Nothing

src/Spago/Search/IndexBuilder.purs+7−2

@@ -1,4 +1,4 @@

1−module Spago.Seach.IndexBuilder where

1+module Spago.Search.IndexBuilder where

33import Prelude

@@ -96,4 +96,9 @@ main = do

9696 writeDeclarations declarations

9797 patchDocs

9898 let index = mkSearchIndex declarations

99− liftEffect $ log $ "Loaded " <> show (Trie.size $ (unwrap index).decls) <> " definitions"

99+ liftEffect $ log $

100+ "Loaded " <>

101+ show (Trie.size $ (unwrap index).decls) <>

102+ " definitions and " <>

103+ show (Trie.size $ (unwrap index).types) <>

104+ " type definitions"

src/Spago/Search/TypeQuery.purs+14−10

@@ -8,7 +8,8 @@ import Data.Either (Either)

88import Data.Foldable (foldl)

99import Data.Generic.Rep (class Generic)

1010import Data.Generic.Rep.Show (genericShow)

11−import Data.List (List(..), some, (:))

11+import Data.String.Common (trim) as String

12+import Data.List (List(..), many, some, (:))

1213import Data.List as List

1314import Data.List.NonEmpty (NonEmptyList, cons', uncons)

1415import Data.List.NonEmpty as NonEmptyList

@@ -26,7 +27,7 @@ data TypeQuery

2627 | QFun TypeQuery TypeQuery

2728 | QApp TypeQuery TypeQuery

2829 | QForAll (NonEmptyList String) TypeQuery

29− | QConstraint String (List String) TypeQuery

30+ | QConstraint String (List TypeQuery) TypeQuery

3031 | QRow (List (Tuple String TypeQuery))

3132

3233derive instance eqTypeQuery :: Eq TypeQuery

@@ -36,7 +37,7 @@ instance showTypeQuery :: Show TypeQuery where

3637 show x = genericShow x

3738

3839parseTypeQuery :: String -> Either ParseError TypeQuery

39−parseTypeQuery = runParser (typeQueryParser <* eof)

40+parseTypeQuery = String.trim >>> runParser (typeQueryParser <* eof)

4041

4142typeQueryParser :: Parser TypeQuery

4243typeQueryParser = fix \typeQuery ->

@@ -45,7 +46,9 @@ typeQueryParser = fix \typeQuery ->

4546 (skipSpaces *> typeQuery <* skipSpaces))

4647 (string "," *> skipSpaces)

4748

48− row = string "{" *> rowFields <* string "}"

49+ row = string "(" *> rowFields <* string ")"

50+

51+ record = QApp (QConst "Record") <$> (string "{" *> rowFields <* string "}")

4952

5053 binders =

5154 string "forall" *> some space *> sepEndBy1 ident (some space) <* string "." <* skipSpaces

@@ -57,8 +60,9 @@ typeQueryParser = fix \typeQuery ->

5760

5861 atom = skipSpaces *> (

5962 for_all <|>

60− parens <|>

63+ try parens <|>

6164 row <|>

65+ record <|>

6266 concrete <|>

6367 any

6468 )

@@ -71,7 +75,7 @@ typeQueryParser = fix \typeQuery ->

7175

7276 constrained =

7377 QConstraint <$> (upperCaseIdent <* some space) <*>

74− (sepEndBy ident (some space) <* string "=>" <* skipSpaces) <*>

78+ (sepEndBy ((QVar <$> ident) <|> parens) (many space) <* string "=>" <* skipSpaces) <*>

7579 typeQuery

7680 in

7781 try constrained <|> funs

@@ -101,19 +105,19 @@ concrete =

101105ident :: Parser String

102106ident = do

103107 head <- anyLetter

104− rest <- Array.many alphaNum

108+ rest <- Array.many (alphaNum <|> char '\'')

105109 pure $ fromCharArray $ pure head <> rest

106110

107111upperCaseIdent :: Parser String

108112upperCaseIdent = do

109113 head <- upperCaseChar

110− rest <- Array.many alphaNum

114+ rest <- Array.many (alphaNum <|> char '\'')

111115 pure $ fromCharArray $ pure head <> rest

112116

113117lowerCaseIdent :: Parser String

114118lowerCaseIdent = do

115119 head <- lowerCaseChar

116− rest <- Array.many alphaNum

120+ rest <- Array.many (alphaNum <|> char '\'')

117121 pure $ fromCharArray $ pure head <> rest

118122

119123space :: Parser Char

@@ -152,7 +156,7 @@ getFreeVariables query = go Set.empty Set.empty (List.singleton $ Next query)

152156 queue = (Next q : Unbind (Set.difference newBound bound) : rest)

153157

154158 go bound free (Next (QConstraint _ vars q) : rest) =

155− go bound (List.foldr (insertIfUnbound bound) free vars) (Next q : rest)

159+ go bound free ((Next <$> vars) <> (Next q : rest))

156160

157161 go bound free (Next (QRow lst) : rest) =

158162 go bound free ((lst <#> snd >>> Next) <> rest)

src/Spago/Search/TypeShape.purs+15−8

@@ -11,7 +11,7 @@ import Data.Generic.Rep.Show (genericShow)

1111import Data.List (List(..), (:))

1212import Data.List as List

1313import Data.List.NonEmpty as NonEmptyList

14−import Data.Maybe (Maybe)

14+import Data.Maybe (Maybe(..))

1515import Data.Set as Set

1616import Data.Tuple (Tuple(..), snd)

1717

@@ -108,10 +108,11 @@ shapeOfType ty = List.reverse $ go (pure ty) Nil

108108 go rest (PVar : acc)

109109

110110 row@(RCons _ _ _) ->

111− go (typesInRow <> rest) (PRow (List.length joined) : acc)

111+ go (typesInRow <> rest) (PRow (List.length joined.rows) : acc)

112112 where

113− joined = List.sortBy (\x y -> compare x.row y.row) $ joinRows row

114− typesInRow = joined <#> (_.ty)

113+ joined = joinRows row

114+ sorted = List.sortBy (\x y -> compare x.row y.row) $ joined.rows

115+ typesInRow = sorted <#> (_.ty)

115116

116117 BinaryNoParensType op l r ->

117118 go (TypeApp (TypeApp op l) r : rest) acc

@@ -128,11 +129,17 @@ joinForAlls ty = go Nil ty

128129 go ({ var, mbKind } : acc) ty'

129130 go acc ty' = { binders: acc, ty: ty' }

130131

131−joinRows :: Type -> List { row :: String

132− , ty :: Type

133− }

132+joinRows :: Type -> { rows :: List { row :: String

133+ , ty :: Type

134+ }

135+ , ty :: Maybe Type }

134136joinRows = go Nil

135137 where

136138 go acc (RCons row ty rest) =

137139 go ({ row, ty } : acc) rest

138− go acc _ = List.reverse acc

140+ go acc ty = { rows: List.reverse acc

141+ , ty:

142+ case ty of

143+ REmpty -> Nothing

144+ ty' -> Just ty'

145+ }

test/Main.purs+12−5

@@ -5,20 +5,27 @@ import Data.Argonaut.Encode

55import Data.Argonaut.Parser

66import Data.Either

77import Data.Maybe

8−import Effect (Effect)

98import Effect.Aff

10−import Effect.Console (log)

119import Partial.Unsafe

1210import Prelude

1311import Spago.Search.DocsJson

1412import Spago.Search.TypeDecoder

13+

14+import Effect (Effect)

15+import Effect.Aff (Aff, launchAff_)

16+import Effect.Class (liftEffect)

17+import Effect.Console (log)

18+import Test.TypeQuery as TypeQuery

19+import Test.TypeShape as TypeShape

1520import Test.Unit (suite, test)

1621import Test.Unit.Assert as Assert

17−import Test.Unit.Main (runTest)

18−import Test.TypeQuery as TypeQuery

22+import Test.Unit.Main (run, runTest)

1923

2024main :: Effect Unit

21−main = runTest do

25+main = do

26+ runTest mainTest

27+

28+mainTest = do

2229 TypeQuery.tests

2330

2431 let mkJson x = unsafePartial $ fromRight $ jsonParser x

test/Test/TypeQuery.purs+21−7

@@ -104,19 +104,19 @@ tests = do

104104 let input = "forall m a. Monad m => a -> m a"

105105 assertRight (parseTypeQuery input)

106106 (QForAll (nl "m" ["a"])

107− (QConstraint "Monad" (l ["m"])

107+ (QConstraint "Monad" (l [QVar "m"])

108108 (QFun (QVar "a")

109109 (QApp (QVar "m") (QVar "a")))))

110110

111111 test "test #19" do

112112 let input = "{ a :: Int }"

113113 assertRight (parseTypeQuery input)

114− (QRow (pure (Tuple "a" (QConst "Int"))))

114+ (QApp (QConst "Record") (QRow (pure (Tuple "a" (QConst "Int")))))

115115

116116 test "test #20" do

117117 let input = "{a::Int}"

118118 assertRight (parseTypeQuery input)

119− (QRow (pure (Tuple "a" (QConst "Int"))))

119+ (QApp (QConst "Record") (QRow (pure (Tuple "a" (QConst "Int")))))

120120

121121 test "test #21" do

122122 let input = "Int"

@@ -129,7 +129,7 @@ tests = do

129129 test "test #23" do

130130 let input = "forall m a. MonadRec m => Process m a -> m a"

131131 assertRight (parseTypeQuery input) (QForAll (nl "m" ("a" : Nil))

132− (QConstraint "MonadRec" ("m" : Nil)

132+ (QConstraint "MonadRec" (l [QVar "m"])

133133 (QFun (QApp (QApp (QConst "Process")

134134 (QVar "m")) (QVar "a"))

135135 (QApp (QVar "m") (QVar "a")))))

@@ -137,17 +137,31 @@ tests = do

137137 test "test #24" do

138138 let input = "forall t f a. Foldable1 t => Apply f => f"

139139 assertRight (parseTypeQuery input) (QForAll (nl "t" ["f", "a"])

140− (QConstraint "Foldable1" (l ["t"])

141− (QConstraint "Apply" ("f" : Nil) (QVar "f"))))

140+ (QConstraint "Foldable1" (l [QVar "t"])

141+ (QConstraint "Apply" (l [QVar "f"]) (QVar "f"))))

142142

143143 test "test #25" do

144144 let input = "forall m a.MonadRec m=>Process m a->m a"

145145 assertRight (parseTypeQuery input) ((QForAll (nl "m" ("a" : Nil))

146− (QConstraint "MonadRec" ("m" : Nil)

146+ (QConstraint "MonadRec" (l [QVar "m"])

147147 (QFun (QApp (QApp (QConst "Process")

148148 (QVar "m")) (QVar "a"))

149149 (QApp (QVar "m") (QVar "a"))))))

150150

151+ test "test #26" do

152+ let input = "m a -> (a -> m b) -> m b"

153+ assertRight (parseTypeQuery input) (QFun (QApp (QVar "m") (QVar "a")) (QFun (QFun (QVar "a") (QApp (QVar "m") (QVar "b"))) (QApp (QVar "m") (QVar "b"))))

154+

155+ test "test #27" do

156+ let input = "forall f a. Alternative f => Lazy (f (List a)) => f a -> f (List a)"

157+ assertRight (parseTypeQuery input) ((QForAll (nl "f" ["a"]))

158+ (QConstraint "Alternative" (l [QVar "f"])

159+ (QConstraint "Lazy" (l [QApp (QVar "f")

160+ (QApp (QConst "List") (QVar "a"))])

161+ (QFun (QApp (QVar "f") (QVar "a"))

162+ (QApp (QVar "f")

163+ (QApp (QConst "List") (QVar "a")))))))

164+

151165 suite "polish notation" do

152166

153167 test "test #1" do

test/Test/TypeShape.pursnew file+90

@@ -0,0 +1,90 @@

1+module Test.TypeShape where

3+import Data.Either

4+import Data.Either

5+import Data.Maybe

6+import Effect.Aff

7+import Partial.Unsafe

8+import Prelude

9+import Spago.Search.DocsJson

10+import Spago.Search.Index

11+import Spago.Search.IndexBuilder

12+import Spago.Search.TypeDecoder

13+import Spago.Search.TypeQuery

14+import Spago.Search.TypeShape

15+

16+import Data.Array as Array

17+import Data.List as List

18+import Data.Maybe (Maybe(..))

19+import Data.Newtype (unwrap)

20+import Data.Search.Trie as Trie

21+import Data.Traversable (for, for_)

22+import Effect (Effect)

23+import Effect.Aff (Aff, launchAff_)

24+import Effect.Class (liftEffect)

25+import Effect.Console (log, logShow)

26+import Node.Encoding (Encoding(UTF8))

27+import Node.FS.Aff (exists, readTextFile, readdir, writeTextFile)

28+import Node.Process as Process

29+import Test.TypeQuery as TypeQuery

30+import Test.Unit (suite, test)

31+import Test.Unit.Assert as Assert

32+import Test.Unit.Main (runTest)

33+

34+-- | Crash-testing query parser on existing types.

35+run :: Aff Unit

36+run = do

37+ paths <- readdir "output"

38+ declarations <- collectDeclarations paths

39+ -- liftEffect $ log $ "Found " <> show (Array.length declarations) <> " modules"

40+ let index = mkSearchIndex declarations

41+ let types = Trie.values ((unwrap index).types)

42+ for_ types \tys -> do

43+ for_ tys \ty -> do

44+ case (unwrap ty).info of

45+ ValueResult { type: ty } -> do

46+ let shown = showType ty

47+ case parseTypeQuery shown of

48+ Left err ->

49+ liftEffect $ log $ show err <> ": \n" <> shown

50+ _ ->

51+ pure unit

52+ _ -> pure unit

53+

54+showType :: Type -> String

55+showType = case _ of

56+ TypeVar _String -> _String

57+ TypeLevelString _String ->

58+ _String

59+ TypeWildcard ->

60+ "_"

61+ TypeConstructor _QualifiedName ->

62+ showQualifiedName _QualifiedName

63+ TypeOp _QualifiedName ->

64+ showQualifiedName _QualifiedName

65+ TypeApp (TypeApp (TypeConstructor (QualifiedName { moduleName: ["Prim"]

66+ , name: "Function" })) t1) t2 ->

67+ showType t1 <> " -> " <> showType t2

68+

69+ TypeApp _Type1 _Type2 ->

70+ showType _Type1 <> " " <> showType _Type2

71+ foralls@(ForAll _String _Type _Maybe_Kind) ->

72+ let joined = joinForAlls foralls in

73+ "forall " <> (List.intercalate " " $ joined.binders <#> (_.var)) <> ". " <> showType joined.ty -- <> " " <> show _Maybe_Kind

74+ ConstrainedType _Constraint _Type ->

75+ showConstraint _Constraint <> " => " <> showType _Type

76+ REmpty ->

77+ "{}"

78+ RCons _String _Type1 _Type2 ->

79+ "(RConsLabel " <> _String <> " " <> showType _Type1 <> " " <> showType _Type2 <> ")"

80+ BinaryNoParensType _TypeOp _Type1 _Type2 ->

81+ showType _Type1 <> " " <> showType _TypeOp <> " " <> showType _Type2

82+ ParensInType _Type ->

83+ "(" <> showType _Type <> ")"

84+

85+showQualifiedName :: QualifiedName -> String

86+showQualifiedName = unwrap >>> (_.name)

87+

88+showConstraint :: Constraint -> String

89+showConstraint (Constraint { constraintClass, constraintArgs }) =

90+ showQualifiedName constraintClass <> " " <> Array.intercalate " " (constraintArgs <#> showType)