f354ade · rowtype-yoga/purescript-docs-search

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

added: TypeShape

commitf354ade0f71c8c7f8edf4bf48d9f9cdbcdb6e8e2 authorklntsky <klntsky@gmail.com> dateFri 28 Jun 2019, 14:58 (7 years ago) parent4e5570d

8 files changed+449−121

compare with master

unifiedsplit

spago.dhall+1−1 src/Spago/Search/App/SearchResults.purs+49−32 src/Spago/Search/Index.purs+46−7 src/Spago/Search/IndexBuilder.purs+1−1 src/Spago/Search/TypeQuery.purs+48−9 src/Spago/Search/TypeShape.purs+138 test/Main.purs+1−1 test/Test/TypeQuery.purs+165−70

spago.dhall+1−1

@@ -20,7 +20,7 @@

2020 , "node-fs"

2121 , "node-fs-aff"

2222 , "node-process"

23− , "psci-support"

23+ , "profunctor"

2424 , "search-trie"

2525 , "strings"

2626 , "string-parsers"

src/Spago/Search/App/SearchResults.purs+49−32

@@ -1,13 +1,15 @@

11module Spago.Search.App.SearchResults where

33import Prelude

45import Spago.Search.Index

56import Spago.Search.TypeDecoder

7+import Spago.Search.TypeShape

8+import Spago.Search.TypeQuery

710import CSS (textWhitespace, whitespacePreWrap)

811import Data.Array as Array

912import Data.Either (Either(..))

10−import Data.List (List(..), (:))

1113import Data.List as List

1214import Data.Maybe (Maybe(..), isNothing, isJust)

1315import Data.Newtype (unwrap, wrap)

@@ -32,8 +34,12 @@ import Web.HTML as HTML

3234import Web.HTML.Location as Location

3335import Web.HTML.Window as Window

3436

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

38+data ResultsType = TypeResults TypeQuery | DeclResults

39+

3540type State = { mbIndex :: Maybe SearchIndex

3641 , results :: Array SearchResult

42+ , resultsType :: ResultsType

3743 , input :: String

3844 , contents :: Element

3945 , resultsCount :: Int

@@ -51,6 +57,7 @@ mkComponent contents =

5157 H.mkComponent

5258 { initialState: const { mbIndex: Nothing

5359 , results: []

60+ , resultsType: DeclResults

5461 , input: ""

5562 , contents

5663 , resultsCount: 25

@@ -87,11 +94,28 @@ handleQuery (SearchFieldMessage (InputUpdated input) next) = do

8794 let path = List.fromFoldable $

8895 String.toCharArray $

8996 String.toLower input

90− H.modify_ (_ { results = Array.concat $

91− List.toUnfoldable $

92− map List.toUnfoldable $

93− Trie.queryValues path $

94− index

97+ eiTypeQuery = parseTypeQuery input

98+ resultsType =

99+ case eiTypeQuery of

100+ Left _ -> DeclResults

101+ Right query

102+ | isValuableQuery query -> TypeResults query

103+ | otherwise -> DeclResults

104+ results =

105+ case resultsType of

106+ DeclResults ->

107+ Array.concat $

108+ List.toUnfoldable $

109+ map List.toUnfoldable $

110+ Trie.queryValues path $

111+ index.decls

112+ TypeResults query ->

113+ List.toUnfoldable $

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

115+ where

116+ shape = shapeOfTypeQuery query

117+ H.modify_ (_ { results = results

118+ , resultsType = resultsType

95119 , resultsCount = 25 })

96120 pure Nothing

97121

@@ -149,10 +173,13 @@ render state =

149173 ]

150174 else

151175 let selectedResults = Array.take state.resultsCount state.results in

152− [ HH.div [ HP.classes [ wrap "result" ] ]

176+ [ HH.div [ HP.classes [ wrap "result" ] ] $

153177 [ HH.text "Found "

154178 , HH.strong_ [ HH.text $ show $ Array.length state.results ]

155− , HH.text " definitions"

179+ , HH.text $

180+ case state.resultsType of

181+ DeclResults -> " definitions."

182+ TypeResults _ -> " definitions with similar types."

156183 ]

157184

158185 , HH.div [ HP.id_ "spage-search-results-container" ] $

@@ -168,7 +195,6 @@ render state =

168195 ]

169196 ]

170197

171−

172198renderSummary :: forall a b. String -> HH.HTML b a

173199renderSummary text =

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

@@ -259,7 +285,11 @@ renderType = case _ of

259285

260286 TypeApp (TypeConstructor (QualifiedName { moduleName: ["Prim"]

261287 , name: "Record" }))

262− record -> renderRow record

288+ record ->

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

290+ , renderType record

291+ , HH.text " }" ]

292+

263293

264294 TypeApp t1 t2 ->

265295 HH.span_ [ renderType t1

@@ -268,10 +298,10 @@ renderType = case _ of

268298 ]

269299

270300 ty@(ForAll _ _ _) ->

271− let foralls = joinForalls ty in

301+ let foralls = joinForAlls ty in

272302 HH.span_ $

273303 [ HH.text "forall" ] <>

274− ( Array.fromFoldable foralls.vars <#>

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

275305 \ { var, mbKind } ->

276306 case mbKind of

277307 Nothing -> HH.text (" " <> var)

@@ -293,11 +323,11 @@ renderType = case _ of

293323 REmpty -> HH.text "{}"

294324 ty@(RCons _ _ _) -> renderRow ty

295325

296− BinaryNoParensType t1 t2 t3 ->

326+ BinaryNoParensType op t1 t2 ->

297327 HH.span_

298328 [ renderType t1

329+ , renderType op

299330 , renderType t2

300− , renderType t3

301331 ]

302332 ParensInType ty ->

303333 HH.span_

@@ -306,14 +336,6 @@ renderType = case _ of

306336 , HH.text ")"

307337 ]

308338

309−joinForalls :: Type -> { vars :: List.List { var :: String, mbKind :: Maybe Kind }

310− , ty :: Type }

311−joinForalls = go Nil

312− where

313− go acc (ForAll var ty mbKind) =

314− go ({ var, mbKind } : acc) ty

315− go acc ty = { vars: acc, ty }

316−

317339renderRow :: forall a. Type -> HH.HTML a Action

318340renderRow ty =

319341 let rows = joinRows ty in

@@ -326,16 +348,6 @@ renderRow ty =

326348 ) <>

327349 [ HH.text " }" ]

328350

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

330− , ty :: Type

331− }

332−joinRows = go Nil

333− where

334− go acc (RCons row ty rest) =

335− go ({ row, ty } : acc) rest

336− go acc _ = List.reverse acc

337−

338−

339351htmlSingleton :: forall t406 t407. HH.HTML t407 t406 -> HH.HTML t407 t406

340352htmlSingleton x = HH.span_ [ x ]

341353

@@ -355,3 +367,8 @@ renderKind = case _ of

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

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

357369 NamedKind qname -> renderQualifiedName qname

370+

371+isValuableQuery :: TypeQuery -> Boolean

372+isValuableQuery (QVar _) = false

373+isValuableQuery (QConst _) = false

374+isValuableQuery _ = true

src/Spago/Search/Index.purs+46−7

@@ -1,9 +1,8 @@

11module Spago.Search.Index where

3+import Data.Tuple

34import Prelude

4−

5−import Spago.Search.TypeDecoder (Constraint, FunDeps, Kind, Type, TypeArgument)

6−import Spago.Search.DocsJson (ChildDeclType(..), ChildIndexEntry(..), DeclType(..), Declarations(..), IndexEntry(..))

5+import Spago.Search.TypeShape

87import Control.Alt ((<|>))

98import Data.Array ((!!))

@@ -11,14 +10,19 @@ import Data.Foldable (foldr)

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

1211import Data.List as List

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

14−import Data.Newtype (class Newtype)

15−import Data.Search.Trie (Trie, alter)

13+import Data.Newtype (class Newtype, unwrap)

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

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

1716import Data.String.Common (toLower)

1817import Data.String.Common as String

1918import Data.String.Pattern (Pattern(..))

19+import Spago.Search.DocsJson (ChildDeclType(..), ChildIndexEntry(..), DeclType(..), Declarations(..), IndexEntry(..))

20+import Spago.Search.TypeDecoder (Constraint, FunDeps, Kind, Type, TypeArgument)

2021

21−newtype SearchIndex = SearchIndex (Trie Char (List SearchResult))

22+newtype SearchIndex

23+ = SearchIndex { decls :: Trie Char (List SearchResult)

24+ , types :: Trie ShapeChunk (List SearchResult)

25+ }

2226

2327derive instance newtypeSearchIndex :: Newtype SearchIndex _

2428

@@ -52,7 +56,42 @@ newtype SearchResult

5256derive instance newtypeSearchResult :: Newtype SearchResult _

5357

5458mkSearchIndex :: Array Declarations -> SearchIndex

55−mkSearchIndex = SearchIndex <<< foldr insertDeclarations mempty

59+mkSearchIndex decls =

60+ SearchIndex { decls: trie

61+ , types

62+ }

63+ where

64+ trie = foldr insertDeclarations mempty decls

65+ types = foldr insertTypes mempty do

66+ Tuple _ results <- entriesUnordered trie

67+ result <- results

68+ case (unwrap result).info of

69+ ValueResult dict ->

70+ insertTypeResultsFor dict.type result

71+ TypeClassMemberResult dict ->

72+ -- TODO: fix missing foralls for type class members

73+ insertTypeResultsFor dict.type result

74+ TypeSynonymResult dict ->

75+ insertTypeResultsFor dict.type result

76+ _ -> mempty

77+

78+ insertTypeResultsFor ty result =

79+ let path = shapeOfType ty in

80+ pure $ Tuple path result

81+

82+insertTypes

83+ :: Tuple (List ShapeChunk) SearchResult

84+ -> Trie ShapeChunk (List SearchResult)

85+ -> Trie ShapeChunk (List SearchResult)

86+insertTypes (Tuple path result) trie =

87+ alter path updateResults trie

88+ where

89+ updateResults mbOldResults =

90+ case mbOldResults of

91+ Just oldResults ->

92+ Just $ result : oldResults

93+ Nothing ->

94+ Just $ List.singleton result

5695

5796insertDeclarations

5897 :: Declarations

src/Spago/Search/IndexBuilder.purs+1−1

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

9696 writeDeclarations declarations

9797 patchDocs

9898 let index = mkSearchIndex declarations

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

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

src/Spago/Search/TypeQuery.purs+48−9

@@ -8,25 +8,26 @@ 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.List (List(..), some, (:))

1212import Data.List as List

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

14+import Data.List.NonEmpty as NonEmptyList

1415import Data.Maybe (Maybe(..))

16+import Data.Set as Set

1517import Data.String.CodeUnits (fromCharArray)

16−import Data.Tuple (Tuple(..))

18+import Data.Tuple (Tuple(..), snd)

1719import Text.Parsing.StringParser (ParseError, Parser, runParser, try)

1820import Text.Parsing.StringParser.CodePoints (alphaNum, anyLetter, char, eof, lowerCaseChar, skipSpaces, string, upperCaseChar)

1921import Text.Parsing.StringParser.Combinators (fix, sepBy, sepBy1, sepEndBy, sepEndBy1)

2022

2123data TypeQuery

22− = QAny String

23− | QConcrete String

24+ = QVar String

25+ | QConst String

2426 | QFun TypeQuery TypeQuery

2527 | QApp TypeQuery TypeQuery

2628 | QForAll (NonEmptyList String) TypeQuery

2729 | QConstraint String (List String) TypeQuery

2830 | QRow (List (Tuple String TypeQuery))

29− | QEmpty

3031

3132derive instance eqTypeQuery :: Eq TypeQuery

3233derive instance genericTypeQuery :: Generic TypeQuery _

@@ -70,8 +71,8 @@ typeQueryParser = fix \typeQuery ->

7071

7172 constrained =

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

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

74− funs

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

75+ typeQuery

7576 in

7677 try constrained <|> funs

7778

@@ -91,11 +92,11 @@ foldr1 f = go List.Nil

9192

9293any :: Parser TypeQuery

9394any = do

94− QAny <$> lowerCaseIdent

95+ QVar <$> lowerCaseIdent

9596

9697concrete :: Parser TypeQuery

9798concrete =

98− QConcrete <$> upperCaseIdent

99+ QConst <$> upperCaseIdent

99100

100101ident :: Parser String

101102ident = do

@@ -117,3 +118,41 @@ lowerCaseIdent = do

117118

118119space :: Parser Char

119120space = char ' '

121+

122+

123+-- | Used only in `getFreeVariables`.

124+data FreeVarCounterQueueEntry = Unbind (Set.Set String) | Next TypeQuery

125+

126+getFreeVariables :: TypeQuery -> Set.Set String

127+getFreeVariables query = go Set.empty Set.empty (List.singleton $ Next query)

128+ where

129+ insertIfUnbound bound var free =

130+ if Set.member var bound

131+ then free

132+ else Set.insert var free

133+

134+ go bound free Nil = free

135+ go bound free (Unbind vars : rest) =

136+ go (Set.difference bound vars) free rest

137+

138+ go bound free (Next (QVar var) : rest) =

139+ go bound (insertIfUnbound bound var free) rest

140+

141+ go bound free (Next (QConst str) : rest) =

142+ go bound free rest

143+ go bound free (Next (QFun q1 q2) : rest) =

144+ go bound free (Next q1 : Next q2 : rest)

145+ go bound free (Next (QApp q1 q2) : rest) =

146+ go bound free (Next q1 : Next q2 : rest)

147+

148+ go bound free (Next (QForAll nl q) : rest) =

149+ go (Set.union bound newBound) free queue

150+ where

151+ newBound = NonEmptyList.foldr Set.insert mempty nl

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

153+

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

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

156+

157+ go bound free (Next (QRow lst) : rest) =

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

src/Spago/Search/TypeShape.pursnew file+138

@@ -0,0 +1,138 @@

1+module Spago.Search.TypeShape where

3+import Prelude

5+import Spago.Search.TypeDecoder

6+import Spago.Search.TypeQuery

7+import Spago.Search.TypeQuery

9+import Data.Generic.Rep (class Generic)

10+import Data.Generic.Rep.Show (genericShow)

11+import Data.List (List(..), (:))

12+import Data.List as List

13+import Data.List.NonEmpty as NonEmptyList

14+import Data.Maybe (Maybe)

15+import Data.Set as Set

16+import Data.Tuple (Tuple(..), snd)

17+

18+type TypeShape = List ShapeChunk

19+

20+data ShapeChunk

21+ = PVar

22+ | PFun

23+ | PApp

24+ | PForAll Int

25+ | PRow Int

26+

27+derive instance eqShapeChunk :: Eq ShapeChunk

28+derive instance ordShapeChunk :: Ord ShapeChunk

29+derive instance genericShapeChunk :: Generic ShapeChunk _

30+

31+instance showShapeChunk :: Show ShapeChunk where

32+ show x = genericShow x

33+

34+shapeOfTypeQuery :: TypeQuery -> TypeShape

35+shapeOfTypeQuery query =

36+ prependForAll $ List.reverse $ go (pure query) Nil

37+ where

38+

39+ prependForAll (PForAll n : rest) =

40+ PForAll (count + n) : rest

41+ prependForAll shape =

42+ if count == 0

43+ then shape

44+ else PForAll count : shape

45+

46+ count = Set.size $ getFreeVariables query

47+

48+ go Nil acc = acc

49+ go (this:rest) acc =

50+ case this of

51+ QVar _ ->

52+ go rest (PVar : acc)

53+ QConst v ->

54+ go rest (PVar : acc)

55+ QFun q1 q2 ->

56+ go (q1 : q2 : rest) (PFun : acc)

57+ QApp q1 q2 ->

58+ go (q1 : q2 : rest) (PApp : acc)

59+ QForAll lst q ->

60+ go (q : rest) (PForAll (NonEmptyList.length lst) : acc)

61+ QConstraint str lst q ->

62+ go (q : rest) acc

63+ QRow lst ->

64+ let lst' = List.sortBy (\(Tuple x _) (Tuple y _) -> compare x y) lst in

65+ go (map snd lst' <> rest) (PRow (List.length lst) : acc)

66+

67+shapeOfType :: Type -> TypeShape

68+shapeOfType ty = List.reverse $ go (pure ty) Nil

69+ where

70+ go Nil acc = acc

71+ go (this:rest) acc =

72+ case this of

73+

74+ TypeVar _ ->

75+ go rest (PVar : acc)

76+

77+ TypeLevelString _ ->

78+ go rest (PVar : acc)

79+

80+ TypeWildcard ->

81+ go rest (PVar : acc)

82+

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

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

85+ go (t1 : t2 : rest) (PFun : acc)

86+

87+ TypeConstructor (QualifiedName { name }) ->

88+ go rest (PVar : acc)

89+

90+ TypeOp _ ->

91+ go rest (PVar : acc)

92+

93+ TypeApp child1 child2 ->

94+ go (child1 : child2 : rest) (PApp : acc)

95+

96+ forallType@(ForAll _ _ _) ->

97+ go (foralls.ty : rest) (PForAll (List.length foralls.binders) : acc)

98+ where foralls = joinForAlls forallType

99+

100+ ParensInType child ->

101+ go (child : rest) acc

102+

103+ ConstrainedType _ child ->

104+ go (child : rest) acc

105+

106+ REmpty ->

107+ -- TODO: reconsider

108+ go rest (PVar : acc)

109+

110+ row@(RCons _ _ _) ->

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

112+ where

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

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

115+

116+ BinaryNoParensType op l r ->

117+ go (TypeApp (TypeApp op l) r : rest) acc

118+

119+joinForAlls

120+ :: Type

121+ -> { binders :: List { var :: String

122+ , mbKind :: Maybe Kind }

123+ , ty :: Type

124+ }

125+joinForAlls ty = go Nil ty

126+ where

127+ go acc (ForAll var ty' mbKind) =

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

129+ go acc ty' = { binders: acc, ty: ty' }

130+

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

132+ , ty :: Type

133+ }

134+joinRows = go Nil

135+ where

136+ go acc (RCons row ty rest) =

137+ go ({ row, ty } : acc) rest

138+ go acc _ = List.reverse acc

test/Main.purs+1−1

@@ -12,7 +12,7 @@ import Partial.Unsafe

1212import Prelude

1313import Spago.Search.DocsJson

1414import Spago.Search.TypeDecoder

15−import Test.Unit (suite, test, timeout)

15+import Test.Unit (suite, test)

1616import Test.Unit.Assert as Assert

1717import Test.Unit.Main (runTest)

1818import Test.TypeQuery as TypeQuery

test/Test/TypeQuery.purs+165−70

@@ -1,136 +1,228 @@

11module Test.TypeQuery where

3−

4−import Data.Argonaut.Decode

5−import Data.Argonaut.Encode

6−import Data.Argonaut.Parser

7−import Data.Either

8−import Data.Maybe

9−import Effect (Effect)

10−import Effect.Aff

11−import Effect.Console (log)

12−import Partial.Unsafe

133import Prelude

144import Spago.Search.DocsJson

15−import Spago.Search.TypeDecoder

165import Spago.Search.TypeQuery

17−import Test.Unit (suite, test, timeout)

18−import Test.Unit.Assert as Assert

19−import Test.Unit.Main (runTest)

20−import Data.List as List

6+import Spago.Search.TypeShape

8+import Data.Either (Either(..), isRight)

9+import Data.Foldable (class Foldable)

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

22−import Data.Tuple

23−import Data.Foldable

11+import Data.List as List

2412import Data.List.NonEmpty (NonEmptyList)

2513import Data.List.NonEmpty as NonEmptyList

14+import Data.Set as Set

15+import Data.Tuple (Tuple(..))

16+import Effect.Aff (Aff)

17+import Test.Unit (TestSuite, suite, test)

18+import Test.Unit.Assert as Assert

2619

27−tests =

20+tests :: TestSuite

21+tests = do

2822 suite "TypeQuery parser" do

2923

3024 test "test #0" do

3125 let input = "a"

32− assertRight (parseTypeQuery input) (QAny "a")

26+ assertRight (parseTypeQuery input) (QVar "a")

3327

34− test "test #0.1" do

28+ test "test #1" do

3529 let input = "ab"

36− assertRight (parseTypeQuery input) (QAny "ab")

30+ assertRight (parseTypeQuery input) (QVar "ab")

3731

38− test "test #1.0" do

32+ test "test #2" do

3933 let input = "a b"

40− assertRight (parseTypeQuery input) (QApp (QAny "a") (QAny "b"))

34+ assertRight (parseTypeQuery input) (QApp (QVar "a") (QVar "b"))

4135

42− test "test #1.1" do

36+ test "test #3" do

4337 let input = "a b c"

44− assertRight (parseTypeQuery input) (QApp (QApp (QAny "a") (QAny "b")) (QAny "c"))

38+ assertRight (parseTypeQuery input) (QApp (QApp (QVar "a") (QVar "b")) (QVar "c"))

4539

46− test "test #2" do

40+ test "test #4" do

4741 let input = "a -> b"

48− assertRight (parseTypeQuery input) (QFun (QAny "a") (QAny "b"))

42+ assertRight (parseTypeQuery input) (QFun (QVar "a") (QVar "b"))

4943

50− test "test #3" do

44+ test "test #5" do

5145 let input = "a -> b c"

52− assertRight (parseTypeQuery input) (QFun (QAny "a") (QApp (QAny "b") (QAny "c")))

46+ assertRight (parseTypeQuery input) (QFun (QVar "a") (QApp (QVar "b") (QVar "c")))

5347

54− test "test #4" do

48+ test "test #6" do

5549 let input = "a b -> c"

56− assertRight (parseTypeQuery input) (QFun (QApp (QAny "a") (QAny "b")) (QAny "c"))

50+ assertRight (parseTypeQuery input) (QFun (QApp (QVar "a") (QVar "b")) (QVar "c"))

5751

58− test "test #5" do

52+ test "test #7" do

5953 let input = "a b"

60− assertRight (parseTypeQuery input) (QApp (QAny "a") (QAny "b"))

54+ assertRight (parseTypeQuery input) (QApp (QVar "a") (QVar "b"))

6155

62− test "test #6" do

56+ test "test #8" do

6357 let input = "a (b c)"

64− assertRight (parseTypeQuery input) (QApp (QAny "a") (QApp (QAny "b") (QAny "c")))

58+ assertRight (parseTypeQuery input) (QApp (QVar "a") (QApp (QVar "b") (QVar "c")))

6559

66− test "test #6.1" do

60+ test "test #9" do

6761 let input = "(a b) (c d)"

6862 assertRight (parseTypeQuery input)

69− (QApp (QApp (QAny "a") (QAny "b"))

70− (QApp (QAny "c") (QAny "d")))

63+ (QApp (QApp (QVar "a") (QVar "b"))

64+ (QApp (QVar "c") (QVar "d")))

7165

72− test "test #7" do

66+ test "test #10" do

7367 let input = "a ( b c )"

74− assertRight (parseTypeQuery input) (QApp (QAny "a") (QApp (QAny "b") (QAny "c")))

68+ assertRight (parseTypeQuery input) (QApp (QVar "a") (QApp (QVar "b") (QVar "c")))

7569

76− test "test #8" do

70+ test "test #11" do

7771 let input = "aaa"

78− assertRight (parseTypeQuery input) (QAny "aaa")

72+ assertRight (parseTypeQuery input) (QVar "aaa")

7973

80− test "test #9" do

74+ test "test #12" do

8175 let input = "aaa ( bbb ccc )"

82− assertRight (parseTypeQuery input) (QApp (QAny "aaa") (QApp (QAny "bbb") (QAny "ccc")))

76+ assertRight (parseTypeQuery input) (QApp (QVar "aaa") (QApp (QVar "bbb") (QVar "ccc")))

8377

84− test "test #10" do

78+ test "test #13" do

8579 let input = "(a -> b) -> (c -> d)"

86− assertRight (parseTypeQuery input) (QFun (QFun (QAny "a") (QAny "b"))

87− (QFun (QAny "c") (QAny "d")))

80+ assertRight (parseTypeQuery input) (QFun (QFun (QVar "a") (QVar "b"))

81+ (QFun (QVar "c") (QVar "d")))

8882

89− test "test #11" do

83+ test "test #14" do

9084 let input = "a -> b -> c -> d"

91− assertRight (parseTypeQuery input) (QFun (QAny "a")

92− (QFun (QAny "b")

93− (QFun (QAny "c") (QAny "d"))))

85+ assertRight (parseTypeQuery input) (QFun (QVar "a")

86+ (QFun (QVar "b")

87+ (QFun (QVar "c") (QVar "d"))))

9488

95− test "test #11.1" do

89+ test "test #15" do

9690 let input = "a -> b -> c"

97− assertRight (parseTypeQuery input) (QFun (QAny "a")

98− (QFun (QAny "b")

99− (QAny "c")))

91+ assertRight (parseTypeQuery input) (QFun (QVar "a")

92+ (QFun (QVar "b")

93+ (QVar "c")))

10094

101− test "test #12" do

95+ test "test #16" do

10296 let input = "forall a b c. c"

103− assertRight (parseTypeQuery input) (QForAll (nl "a" ["b", "c"]) (QAny "c"))

97+ assertRight (parseTypeQuery input) (QForAll (nl "a" ["b", "c"]) (QVar "c"))

10498

105− test "test #13" do

99+ test "test #17" do

106100 let input = "forall a. Maybe a"

107− assertRight (parseTypeQuery input) (QForAll (nl "a" $ []) (QApp (QConcrete "Maybe") (QAny "a")))

101+ assertRight (parseTypeQuery input) (QForAll (nl "a" $ []) (QApp (QConst "Maybe") (QVar "a")))

108102

109− test "test #14" do

103+ test "test #18" do

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

111105 assertRight (parseTypeQuery input)

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

113107 (QConstraint "Monad" (l ["m"])

114− (QFun (QAny "a")

115− (QApp (QAny "m") (QAny "a")))))

108+ (QFun (QVar "a")

109+ (QApp (QVar "m") (QVar "a")))))

116110

117− test "test #15" do

111+ test "test #19" do

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

119113 assertRight (parseTypeQuery input)

120− (QRow (pure (Tuple "a" (QConcrete "Int"))))

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

121115

122− test "test #16" do

116+ test "test #20" do

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

124118 assertRight (parseTypeQuery input)

125− (QRow (pure (Tuple "a" (QConcrete "Int"))))

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

126120

127− test "test #17" do

121+ test "test #21" do

128122 let input = "Int"

129− assertRight (parseTypeQuery input) (QConcrete "Int")

123+ assertRight (parseTypeQuery input) (QConst "Int")

130124

131− test "test #18" do

125+ test "test #22" do

132126 let input = "a->b"

133− assertRight (parseTypeQuery input) (QFun (QAny "a") (QAny "b"))

127+ assertRight (parseTypeQuery input) (QFun (QVar "a") (QVar "b"))

128+

129+ test "test #23" do

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

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

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

133+ (QFun (QApp (QApp (QConst "Process")

134+ (QVar "m")) (QVar "a"))

135+ (QApp (QVar "m") (QVar "a")))))

136+

137+ test "test #24" do

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

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

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

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

142+

143+ test "test #25" do

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

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

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

147+ (QFun (QApp (QApp (QConst "Process")

148+ (QVar "m")) (QVar "a"))

149+ (QApp (QVar "m") (QVar "a"))))))

150+

151+ suite "polish notation" do

152+

153+ test "test #1" do

154+ let input = "(a -> b) -> (b -> ((a -> b) -> c))"

155+ assertRight (shapeOfTypeQuery <$> parseTypeQuery input)

156+ (l [ PForAll 3, PFun, PFun, PVar, PVar, PFun, PVar, PFun, PFun

157+ , PVar, PVar, PVar ])

158+

159+ test "test #2" do

160+ let input = "forall a. (a -> b) -> (b -> ((a -> b) -> c))"

161+ assertRight (shapeOfTypeQuery <$> parseTypeQuery input)

162+ (l [ PForAll 3, PFun, PFun, PVar, PVar, PFun, PVar, PFun, PFun

163+ , PVar, PVar, PVar ])

164+

165+ test "test #3" do

166+ let input = "forall a. (a -> b) -> (b -> ((a -> b) -> c))"

167+ assertRight (shapeOfTypeQuery <$> parseTypeQuery input)

168+ (l [ PForAll 3, PFun, PFun, PVar, PVar, PFun, PVar, PFun, PFun

169+ , PVar, PVar, PVar ])

170+

171+ test "test #4" do

172+ let input = "forall a. (forall h. ST h (STArray h a)) -> Array a"

173+ assertRight (shapeOfTypeQuery <$> parseTypeQuery input)

174+ (l [ PForAll 1, PFun, PForAll 1, PApp, PApp, PVar, PVar, PApp, PApp, PVar, PVar, PVar, PApp, PVar, PVar ])

175+

176+ suite "free variable counting" do

177+

178+ test "test #1" do

179+ let input = "forall a. (a -> b) -> (b -> ((a -> b) -> c))"

180+ assertRight (countFreeVars <$> parseTypeQuery input) 2

181+

182+ test "test #2" do

183+ -- `b` is not bound on the left, `a` is not bound on the right

184+ let input = "(forall a. (a -> b)) -> forall b. (b -> a)"

185+ assertRight (countFreeVars <$> parseTypeQuery input) 2

186+

187+ test "test #3" do

188+ let input = "a -> forall a. a"

189+ assertRight (countFreeVars <$> parseTypeQuery input) 1

190+

191+ test "test #4" do

192+ let input = "(forall a. a) -> a"

193+ assertRight (countFreeVars <$> parseTypeQuery input) 1

194+

195+ test "test #5" do

196+ let input = "forall a. a -> a"

197+ assertRight (countFreeVars <$> parseTypeQuery input) 0

198+

199+ test "test #6" do

200+ let input = "a -> b -> c"

201+ assertRight (countFreeVars <$> parseTypeQuery input) 3

202+

203+ test "test #7" do

204+ let input = "forall m a. Monad m => a -> m a"

205+ assertRight (countFreeVars <$> parseTypeQuery input) 0

206+

207+ test "test #8" do

208+ let input = "Monad m => a -> m a"

209+ assertRight (countFreeVars <$> parseTypeQuery input) 2

210+

211+ test "test #9" do

212+ let input = "Monad m => a -> a"

213+ assertRight (countFreeVars <$> parseTypeQuery input) 2

214+

215+ test "test #10" do

216+ let input = "forall a. (forall a. a) a"

217+ assertRight (countFreeVars <$> parseTypeQuery input) 0

218+

219+ test "test #11" do

220+ let input = "forall a. (forall b. a) a"

221+ assertRight (countFreeVars <$> parseTypeQuery input) 0

222+

223+ test "test #12" do

224+ let input = "forall a. (forall b. a) a b"

225+ assertRight (countFreeVars <$> parseTypeQuery input) 1

134226

135227l :: forall f. Foldable f => (forall a. f a -> List a)

136228l = List.fromFoldable

@@ -153,3 +245,6 @@ assertRight eiActual expected =

153245 Assert.equal (Right expected) eiActual

154246 Right actual -> do

155247 Assert.equal (Right expected) eiActual

248+

249+countFreeVars :: TypeQuery -> Int

250+countFreeVars = getFreeVariables >>> Set.size