mirror of
https://github.com/rowtype-yoga/purescript-docs-search.git
synced 2024-09-11 12:35:37 +03:00
added: TypeShape
This commit is contained in:
klntsky
parent
4e5570df7d
commit
f354ade0f7
@ -20,7 +20,7 @@
|
||||
, "node-fs"
|
||||
, "node-fs-aff"
|
||||
, "node-process"
|
||||
, "psci-support"
|
||||
, "profunctor"
|
||||
, "search-trie"
|
||||
, "strings"
|
||||
, "string-parsers"
|
||||
|
||||
@ -1,13 +1,15 @@
|
||||
module Spago.Search.App.SearchResults where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Spago.Search.Index
|
||||
import Spago.Search.TypeDecoder
|
||||
import Spago.Search.TypeShape
|
||||
import Spago.Search.TypeQuery
|
||||
|
||||
import CSS (textWhitespace, whitespacePreWrap)
|
||||
import Data.Array as Array
|
||||
import Data.Either (Either(..))
|
||||
import Data.List (List(..), (:))
|
||||
import Data.List as List
|
||||
import Data.Maybe (Maybe(..), isNothing, isJust)
|
||||
import Data.Newtype (unwrap, wrap)
|
||||
@ -32,8 +34,12 @@ import Web.HTML as HTML
|
||||
import Web.HTML.Location as Location
|
||||
import Web.HTML.Window as Window
|
||||
|
||||
-- | Is it a search by type or by declaration?
|
||||
data ResultsType = TypeResults TypeQuery | DeclResults
|
||||
|
||||
type State = { mbIndex :: Maybe SearchIndex
|
||||
, results :: Array SearchResult
|
||||
, resultsType :: ResultsType
|
||||
, input :: String
|
||||
, contents :: Element
|
||||
, resultsCount :: Int
|
||||
@ -51,6 +57,7 @@ mkComponent contents =
|
||||
H.mkComponent
|
||||
{ initialState: const { mbIndex: Nothing
|
||||
, results: []
|
||||
, resultsType: DeclResults
|
||||
, input: ""
|
||||
, contents
|
||||
, resultsCount: 25
|
||||
@ -87,11 +94,28 @@ handleQuery (SearchFieldMessage (InputUpdated input) next) = do
|
||||
let path = List.fromFoldable $
|
||||
String.toCharArray $
|
||||
String.toLower input
|
||||
H.modify_ (_ { results = Array.concat $
|
||||
List.toUnfoldable $
|
||||
map List.toUnfoldable $
|
||||
Trie.queryValues path $
|
||||
index
|
||||
eiTypeQuery = parseTypeQuery input
|
||||
resultsType =
|
||||
case eiTypeQuery of
|
||||
Left _ -> DeclResults
|
||||
Right query
|
||||
| isValuableQuery query -> TypeResults query
|
||||
| otherwise -> DeclResults
|
||||
results =
|
||||
case resultsType of
|
||||
DeclResults ->
|
||||
Array.concat $
|
||||
List.toUnfoldable $
|
||||
map List.toUnfoldable $
|
||||
Trie.queryValues path $
|
||||
index.decls
|
||||
TypeResults query ->
|
||||
List.toUnfoldable $
|
||||
Trie.queryValues shape index.types >>= identity
|
||||
where
|
||||
shape = shapeOfTypeQuery query
|
||||
H.modify_ (_ { results = results
|
||||
, resultsType = resultsType
|
||||
, resultsCount = 25 })
|
||||
pure Nothing
|
||||
|
||||
@ -149,10 +173,13 @@ render state =
|
||||
]
|
||||
else
|
||||
let selectedResults = Array.take state.resultsCount state.results in
|
||||
[ HH.div [ HP.classes [ wrap "result" ] ]
|
||||
[ HH.div [ HP.classes [ wrap "result" ] ] $
|
||||
[ HH.text "Found "
|
||||
, HH.strong_ [ HH.text $ show $ Array.length state.results ]
|
||||
, HH.text " definitions"
|
||||
, HH.text $
|
||||
case state.resultsType of
|
||||
DeclResults -> " definitions."
|
||||
TypeResults _ -> " definitions with similar types."
|
||||
]
|
||||
|
||||
, HH.div [ HP.id_ "spage-search-results-container" ] $
|
||||
@ -168,7 +195,6 @@ render state =
|
||||
]
|
||||
]
|
||||
|
||||
|
||||
renderSummary :: forall a b. String -> HH.HTML b a
|
||||
renderSummary text =
|
||||
HH.div [ HP.id_ "spago-search-summary" ]
|
||||
@ -259,7 +285,11 @@ renderType = case _ of
|
||||
|
||||
TypeApp (TypeConstructor (QualifiedName { moduleName: ["Prim"]
|
||||
, name: "Record" }))
|
||||
record -> renderRow record
|
||||
record ->
|
||||
HH.span_ [ HH.text "{ | "
|
||||
, renderType record
|
||||
, HH.text " }" ]
|
||||
|
||||
|
||||
TypeApp t1 t2 ->
|
||||
HH.span_ [ renderType t1
|
||||
@ -268,10 +298,10 @@ renderType = case _ of
|
||||
]
|
||||
|
||||
ty@(ForAll _ _ _) ->
|
||||
let foralls = joinForalls ty in
|
||||
let foralls = joinForAlls ty in
|
||||
HH.span_ $
|
||||
[ HH.text "forall" ] <>
|
||||
( Array.fromFoldable foralls.vars <#>
|
||||
( Array.fromFoldable foralls.binders <#>
|
||||
\ { var, mbKind } ->
|
||||
case mbKind of
|
||||
Nothing -> HH.text (" " <> var)
|
||||
@ -293,11 +323,11 @@ renderType = case _ of
|
||||
REmpty -> HH.text "{}"
|
||||
ty@(RCons _ _ _) -> renderRow ty
|
||||
|
||||
BinaryNoParensType t1 t2 t3 ->
|
||||
BinaryNoParensType op t1 t2 ->
|
||||
HH.span_
|
||||
[ renderType t1
|
||||
, renderType op
|
||||
, renderType t2
|
||||
, renderType t3
|
||||
]
|
||||
ParensInType ty ->
|
||||
HH.span_
|
||||
@ -306,14 +336,6 @@ renderType = case _ of
|
||||
, HH.text ")"
|
||||
]
|
||||
|
||||
joinForalls :: Type -> { vars :: List.List { var :: String, mbKind :: Maybe Kind }
|
||||
, ty :: Type }
|
||||
joinForalls = go Nil
|
||||
where
|
||||
go acc (ForAll var ty mbKind) =
|
||||
go ({ var, mbKind } : acc) ty
|
||||
go acc ty = { vars: acc, ty }
|
||||
|
||||
renderRow :: forall a. Type -> HH.HTML a Action
|
||||
renderRow ty =
|
||||
let rows = joinRows ty in
|
||||
@ -326,16 +348,6 @@ renderRow ty =
|
||||
) <>
|
||||
[ HH.text " }" ]
|
||||
|
||||
joinRows :: Type -> List { row :: String
|
||||
, ty :: Type
|
||||
}
|
||||
joinRows = go Nil
|
||||
where
|
||||
go acc (RCons row ty rest) =
|
||||
go ({ row, ty } : acc) rest
|
||||
go acc _ = List.reverse acc
|
||||
|
||||
|
||||
htmlSingleton :: forall t406 t407. HH.HTML t407 t406 -> HH.HTML t407 t406
|
||||
htmlSingleton x = HH.span_ [ x ]
|
||||
|
||||
@ -355,3 +367,8 @@ renderKind = case _ of
|
||||
Row k1 -> HH.span_ [ HH.text "#", renderKind k1 ]
|
||||
FunKind k1 k2 -> HH.span_ [ renderKind k1, renderKind k2 ]
|
||||
NamedKind qname -> renderQualifiedName qname
|
||||
|
||||
isValuableQuery :: TypeQuery -> Boolean
|
||||
isValuableQuery (QVar _) = false
|
||||
isValuableQuery (QConst _) = false
|
||||
isValuableQuery _ = true
|
||||
|
||||
@ -1,9 +1,8 @@
|
||||
module Spago.Search.Index where
|
||||
|
||||
import Data.Tuple
|
||||
import Prelude
|
||||
|
||||
import Spago.Search.TypeDecoder (Constraint, FunDeps, Kind, Type, TypeArgument)
|
||||
import Spago.Search.DocsJson (ChildDeclType(..), ChildIndexEntry(..), DeclType(..), Declarations(..), IndexEntry(..))
|
||||
import Spago.Search.TypeShape
|
||||
|
||||
import Control.Alt ((<|>))
|
||||
import Data.Array ((!!))
|
||||
@ -11,14 +10,19 @@ import Data.Foldable (foldr)
|
||||
import Data.List (List, (:))
|
||||
import Data.List as List
|
||||
import Data.Maybe (Maybe(..), fromMaybe)
|
||||
import Data.Newtype (class Newtype)
|
||||
import Data.Search.Trie (Trie, alter)
|
||||
import Data.Newtype (class Newtype, unwrap)
|
||||
import Data.Search.Trie (Trie, alter, entriesUnordered, fromList, insert)
|
||||
import Data.String.CodeUnits (stripPrefix, stripSuffix, toCharArray)
|
||||
import Data.String.Common (toLower)
|
||||
import Data.String.Common as String
|
||||
import Data.String.Pattern (Pattern(..))
|
||||
import Spago.Search.DocsJson (ChildDeclType(..), ChildIndexEntry(..), DeclType(..), Declarations(..), IndexEntry(..))
|
||||
import Spago.Search.TypeDecoder (Constraint, FunDeps, Kind, Type, TypeArgument)
|
||||
|
||||
newtype SearchIndex = SearchIndex (Trie Char (List SearchResult))
|
||||
newtype SearchIndex
|
||||
= SearchIndex { decls :: Trie Char (List SearchResult)
|
||||
, types :: Trie ShapeChunk (List SearchResult)
|
||||
}
|
||||
|
||||
derive instance newtypeSearchIndex :: Newtype SearchIndex _
|
||||
|
||||
@ -52,7 +56,42 @@ newtype SearchResult
|
||||
derive instance newtypeSearchResult :: Newtype SearchResult _
|
||||
|
||||
mkSearchIndex :: Array Declarations -> SearchIndex
|
||||
mkSearchIndex = SearchIndex <<< foldr insertDeclarations mempty
|
||||
mkSearchIndex decls =
|
||||
SearchIndex { decls: trie
|
||||
, types
|
||||
}
|
||||
where
|
||||
trie = foldr insertDeclarations mempty decls
|
||||
types = foldr insertTypes mempty do
|
||||
Tuple _ results <- entriesUnordered trie
|
||||
result <- results
|
||||
case (unwrap result).info of
|
||||
ValueResult dict ->
|
||||
insertTypeResultsFor dict.type result
|
||||
TypeClassMemberResult dict ->
|
||||
-- TODO: fix missing foralls for type class members
|
||||
insertTypeResultsFor dict.type result
|
||||
TypeSynonymResult dict ->
|
||||
insertTypeResultsFor dict.type result
|
||||
_ -> mempty
|
||||
|
||||
insertTypeResultsFor ty result =
|
||||
let path = shapeOfType ty in
|
||||
pure $ Tuple path result
|
||||
|
||||
insertTypes
|
||||
:: Tuple (List ShapeChunk) SearchResult
|
||||
-> Trie ShapeChunk (List SearchResult)
|
||||
-> Trie ShapeChunk (List SearchResult)
|
||||
insertTypes (Tuple path result) trie =
|
||||
alter path updateResults trie
|
||||
where
|
||||
updateResults mbOldResults =
|
||||
case mbOldResults of
|
||||
Just oldResults ->
|
||||
Just $ result : oldResults
|
||||
Nothing ->
|
||||
Just $ List.singleton result
|
||||
|
||||
insertDeclarations
|
||||
:: Declarations
|
||||
|
||||
@ -96,4 +96,4 @@ main = do
|
||||
writeDeclarations declarations
|
||||
patchDocs
|
||||
let index = mkSearchIndex declarations
|
||||
liftEffect $ log $ "Loaded " <> show (Trie.size $ unwrap index) <> " definitions"
|
||||
liftEffect $ log $ "Loaded " <> show (Trie.size $ (unwrap index).decls) <> " definitions"
|
||||
|
||||
@ -8,25 +8,26 @@ import Data.Either (Either)
|
||||
import Data.Foldable (foldl)
|
||||
import Data.Generic.Rep (class Generic)
|
||||
import Data.Generic.Rep.Show (genericShow)
|
||||
import Data.List (List, some, (:))
|
||||
import Data.List (List(..), some, (:))
|
||||
import Data.List as List
|
||||
import Data.List.NonEmpty (NonEmptyList, cons', uncons)
|
||||
import Data.List.NonEmpty as NonEmptyList
|
||||
import Data.Maybe (Maybe(..))
|
||||
import Data.Set as Set
|
||||
import Data.String.CodeUnits (fromCharArray)
|
||||
import Data.Tuple (Tuple(..))
|
||||
import Data.Tuple (Tuple(..), snd)
|
||||
import Text.Parsing.StringParser (ParseError, Parser, runParser, try)
|
||||
import Text.Parsing.StringParser.CodePoints (alphaNum, anyLetter, char, eof, lowerCaseChar, skipSpaces, string, upperCaseChar)
|
||||
import Text.Parsing.StringParser.Combinators (fix, sepBy, sepBy1, sepEndBy, sepEndBy1)
|
||||
|
||||
data TypeQuery
|
||||
= QAny String
|
||||
| QConcrete String
|
||||
= QVar String
|
||||
| QConst String
|
||||
| QFun TypeQuery TypeQuery
|
||||
| QApp TypeQuery TypeQuery
|
||||
| QForAll (NonEmptyList String) TypeQuery
|
||||
| QConstraint String (List String) TypeQuery
|
||||
| QRow (List (Tuple String TypeQuery))
|
||||
| QEmpty
|
||||
|
||||
derive instance eqTypeQuery :: Eq TypeQuery
|
||||
derive instance genericTypeQuery :: Generic TypeQuery _
|
||||
@ -70,8 +71,8 @@ typeQueryParser = fix \typeQuery ->
|
||||
|
||||
constrained =
|
||||
QConstraint <$> (upperCaseIdent <* some space) <*>
|
||||
(sepEndBy ident (some space) <* string "=>") <*>
|
||||
funs
|
||||
(sepEndBy ident (some space) <* string "=>" <* skipSpaces) <*>
|
||||
typeQuery
|
||||
in
|
||||
try constrained <|> funs
|
||||
|
||||
@ -91,11 +92,11 @@ foldr1 f = go List.Nil
|
||||
|
||||
any :: Parser TypeQuery
|
||||
any = do
|
||||
QAny <$> lowerCaseIdent
|
||||
QVar <$> lowerCaseIdent
|
||||
|
||||
concrete :: Parser TypeQuery
|
||||
concrete =
|
||||
QConcrete <$> upperCaseIdent
|
||||
QConst <$> upperCaseIdent
|
||||
|
||||
ident :: Parser String
|
||||
ident = do
|
||||
@ -117,3 +118,41 @@ lowerCaseIdent = do
|
||||
|
||||
space :: Parser Char
|
||||
space = char ' '
|
||||
|
||||
|
||||
-- | Used only in `getFreeVariables`.
|
||||
data FreeVarCounterQueueEntry = Unbind (Set.Set String) | Next TypeQuery
|
||||
|
||||
getFreeVariables :: TypeQuery -> Set.Set String
|
||||
getFreeVariables query = go Set.empty Set.empty (List.singleton $ Next query)
|
||||
where
|
||||
insertIfUnbound bound var free =
|
||||
if Set.member var bound
|
||||
then free
|
||||
else Set.insert var free
|
||||
|
||||
go bound free Nil = free
|
||||
go bound free (Unbind vars : rest) =
|
||||
go (Set.difference bound vars) free rest
|
||||
|
||||
go bound free (Next (QVar var) : rest) =
|
||||
go bound (insertIfUnbound bound var free) rest
|
||||
|
||||
go bound free (Next (QConst str) : rest) =
|
||||
go bound free rest
|
||||
go bound free (Next (QFun q1 q2) : rest) =
|
||||
go bound free (Next q1 : Next q2 : rest)
|
||||
go bound free (Next (QApp q1 q2) : rest) =
|
||||
go bound free (Next q1 : Next q2 : rest)
|
||||
|
||||
go bound free (Next (QForAll nl q) : rest) =
|
||||
go (Set.union bound newBound) free queue
|
||||
where
|
||||
newBound = NonEmptyList.foldr Set.insert mempty nl
|
||||
queue = (Next q : Unbind (Set.difference newBound bound) : rest)
|
||||
|
||||
go bound free (Next (QConstraint _ vars q) : rest) =
|
||||
go bound (List.foldr (insertIfUnbound bound) free vars) (Next q : rest)
|
||||
|
||||
go bound free (Next (QRow lst) : rest) =
|
||||
go bound free ((lst <#> snd >>> Next) <> rest)
|
||||
|
||||
138
src/Spago/Search/TypeShape.purs
Normal file
138
src/Spago/Search/TypeShape.purs
Normal file
@ -0,0 +1,138 @@
|
||||
module Spago.Search.TypeShape where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Spago.Search.TypeDecoder
|
||||
import Spago.Search.TypeQuery
|
||||
import Spago.Search.TypeQuery
|
||||
|
||||
import Data.Generic.Rep (class Generic)
|
||||
import Data.Generic.Rep.Show (genericShow)
|
||||
import Data.List (List(..), (:))
|
||||
import Data.List as List
|
||||
import Data.List.NonEmpty as NonEmptyList
|
||||
import Data.Maybe (Maybe)
|
||||
import Data.Set as Set
|
||||
import Data.Tuple (Tuple(..), snd)
|
||||
|
||||
type TypeShape = List ShapeChunk
|
||||
|
||||
data ShapeChunk
|
||||
= PVar
|
||||
| PFun
|
||||
| PApp
|
||||
| PForAll Int
|
||||
| PRow Int
|
||||
|
||||
derive instance eqShapeChunk :: Eq ShapeChunk
|
||||
derive instance ordShapeChunk :: Ord ShapeChunk
|
||||
derive instance genericShapeChunk :: Generic ShapeChunk _
|
||||
|
||||
instance showShapeChunk :: Show ShapeChunk where
|
||||
show x = genericShow x
|
||||
|
||||
shapeOfTypeQuery :: TypeQuery -> TypeShape
|
||||
shapeOfTypeQuery query =
|
||||
prependForAll $ List.reverse $ go (pure query) Nil
|
||||
where
|
||||
|
||||
prependForAll (PForAll n : rest) =
|
||||
PForAll (count + n) : rest
|
||||
prependForAll shape =
|
||||
if count == 0
|
||||
then shape
|
||||
else PForAll count : shape
|
||||
|
||||
count = Set.size $ getFreeVariables query
|
||||
|
||||
go Nil acc = acc
|
||||
go (this:rest) acc =
|
||||
case this of
|
||||
QVar _ ->
|
||||
go rest (PVar : acc)
|
||||
QConst v ->
|
||||
go rest (PVar : acc)
|
||||
QFun q1 q2 ->
|
||||
go (q1 : q2 : rest) (PFun : acc)
|
||||
QApp q1 q2 ->
|
||||
go (q1 : q2 : rest) (PApp : acc)
|
||||
QForAll lst q ->
|
||||
go (q : rest) (PForAll (NonEmptyList.length lst) : acc)
|
||||
QConstraint str lst q ->
|
||||
go (q : rest) acc
|
||||
QRow lst ->
|
||||
let lst' = List.sortBy (\(Tuple x _) (Tuple y _) -> compare x y) lst in
|
||||
go (map snd lst' <> rest) (PRow (List.length lst) : acc)
|
||||
|
||||
shapeOfType :: Type -> TypeShape
|
||||
shapeOfType ty = List.reverse $ go (pure ty) Nil
|
||||
where
|
||||
go Nil acc = acc
|
||||
go (this:rest) acc =
|
||||
case this of
|
||||
|
||||
TypeVar _ ->
|
||||
go rest (PVar : acc)
|
||||
|
||||
TypeLevelString _ ->
|
||||
go rest (PVar : acc)
|
||||
|
||||
TypeWildcard ->
|
||||
go rest (PVar : acc)
|
||||
|
||||
TypeApp (TypeApp (TypeConstructor (QualifiedName { moduleName: ["Prim"]
|
||||
, name: "Function" })) t1) t2 ->
|
||||
go (t1 : t2 : rest) (PFun : acc)
|
||||
|
||||
TypeConstructor (QualifiedName { name }) ->
|
||||
go rest (PVar : acc)
|
||||
|
||||
TypeOp _ ->
|
||||
go rest (PVar : acc)
|
||||
|
||||
TypeApp child1 child2 ->
|
||||
go (child1 : child2 : rest) (PApp : acc)
|
||||
|
||||
forallType@(ForAll _ _ _) ->
|
||||
go (foralls.ty : rest) (PForAll (List.length foralls.binders) : acc)
|
||||
where foralls = joinForAlls forallType
|
||||
|
||||
ParensInType child ->
|
||||
go (child : rest) acc
|
||||
|
||||
ConstrainedType _ child ->
|
||||
go (child : rest) acc
|
||||
|
||||
REmpty ->
|
||||
-- TODO: reconsider
|
||||
go rest (PVar : acc)
|
||||
|
||||
row@(RCons _ _ _) ->
|
||||
go (typesInRow <> rest) (PRow (List.length joined) : acc)
|
||||
where
|
||||
joined = List.sortBy (\x y -> compare x.row y.row) $ joinRows row
|
||||
typesInRow = joined <#> (_.ty)
|
||||
|
||||
BinaryNoParensType op l r ->
|
||||
go (TypeApp (TypeApp op l) r : rest) acc
|
||||
|
||||
joinForAlls
|
||||
:: Type
|
||||
-> { binders :: List { var :: String
|
||||
, mbKind :: Maybe Kind }
|
||||
, ty :: Type
|
||||
}
|
||||
joinForAlls ty = go Nil ty
|
||||
where
|
||||
go acc (ForAll var ty' mbKind) =
|
||||
go ({ var, mbKind } : acc) ty'
|
||||
go acc ty' = { binders: acc, ty: ty' }
|
||||
|
||||
joinRows :: Type -> List { row :: String
|
||||
, ty :: Type
|
||||
}
|
||||
joinRows = go Nil
|
||||
where
|
||||
go acc (RCons row ty rest) =
|
||||
go ({ row, ty } : acc) rest
|
||||
go acc _ = List.reverse acc
|
||||
@ -12,7 +12,7 @@ import Partial.Unsafe
|
||||
import Prelude
|
||||
import Spago.Search.DocsJson
|
||||
import Spago.Search.TypeDecoder
|
||||
import Test.Unit (suite, test, timeout)
|
||||
import Test.Unit (suite, test)
|
||||
import Test.Unit.Assert as Assert
|
||||
import Test.Unit.Main (runTest)
|
||||
import Test.TypeQuery as TypeQuery
|
||||
|
||||
@ -1,136 +1,228 @@
|
||||
module Test.TypeQuery where
|
||||
|
||||
|
||||
import Data.Argonaut.Decode
|
||||
import Data.Argonaut.Encode
|
||||
import Data.Argonaut.Parser
|
||||
import Data.Either
|
||||
import Data.Maybe
|
||||
import Effect (Effect)
|
||||
import Effect.Aff
|
||||
import Effect.Console (log)
|
||||
import Partial.Unsafe
|
||||
import Prelude
|
||||
import Spago.Search.DocsJson
|
||||
import Spago.Search.TypeDecoder
|
||||
import Spago.Search.TypeQuery
|
||||
import Test.Unit (suite, test, timeout)
|
||||
import Test.Unit.Assert as Assert
|
||||
import Test.Unit.Main (runTest)
|
||||
import Data.List as List
|
||||
import Spago.Search.TypeShape
|
||||
|
||||
import Data.Either (Either(..), isRight)
|
||||
import Data.Foldable (class Foldable)
|
||||
import Data.List (List(..), (:))
|
||||
import Data.Tuple
|
||||
import Data.Foldable
|
||||
import Data.List as List
|
||||
import Data.List.NonEmpty (NonEmptyList)
|
||||
import Data.List.NonEmpty as NonEmptyList
|
||||
import Data.Set as Set
|
||||
import Data.Tuple (Tuple(..))
|
||||
import Effect.Aff (Aff)
|
||||
import Test.Unit (TestSuite, suite, test)
|
||||
import Test.Unit.Assert as Assert
|
||||
|
||||
tests =
|
||||
tests :: TestSuite
|
||||
tests = do
|
||||
suite "TypeQuery parser" do
|
||||
|
||||
test "test #0" do
|
||||
let input = "a"
|
||||
assertRight (parseTypeQuery input) (QAny "a")
|
||||
assertRight (parseTypeQuery input) (QVar "a")
|
||||
|
||||
test "test #0.1" do
|
||||
test "test #1" do
|
||||
let input = "ab"
|
||||
assertRight (parseTypeQuery input) (QAny "ab")
|
||||
|
||||
test "test #1.0" do
|
||||
let input = "a b"
|
||||
assertRight (parseTypeQuery input) (QApp (QAny "a") (QAny "b"))
|
||||
|
||||
test "test #1.1" do
|
||||
let input = "a b c"
|
||||
assertRight (parseTypeQuery input) (QApp (QApp (QAny "a") (QAny "b")) (QAny "c"))
|
||||
assertRight (parseTypeQuery input) (QVar "ab")
|
||||
|
||||
test "test #2" do
|
||||
let input = "a -> b"
|
||||
assertRight (parseTypeQuery input) (QFun (QAny "a") (QAny "b"))
|
||||
let input = "a b"
|
||||
assertRight (parseTypeQuery input) (QApp (QVar "a") (QVar "b"))
|
||||
|
||||
test "test #3" do
|
||||
let input = "a -> b c"
|
||||
assertRight (parseTypeQuery input) (QFun (QAny "a") (QApp (QAny "b") (QAny "c")))
|
||||
let input = "a b c"
|
||||
assertRight (parseTypeQuery input) (QApp (QApp (QVar "a") (QVar "b")) (QVar "c"))
|
||||
|
||||
test "test #4" do
|
||||
let input = "a b -> c"
|
||||
assertRight (parseTypeQuery input) (QFun (QApp (QAny "a") (QAny "b")) (QAny "c"))
|
||||
let input = "a -> b"
|
||||
assertRight (parseTypeQuery input) (QFun (QVar "a") (QVar "b"))
|
||||
|
||||
test "test #5" do
|
||||
let input = "a b"
|
||||
assertRight (parseTypeQuery input) (QApp (QAny "a") (QAny "b"))
|
||||
let input = "a -> b c"
|
||||
assertRight (parseTypeQuery input) (QFun (QVar "a") (QApp (QVar "b") (QVar "c")))
|
||||
|
||||
test "test #6" do
|
||||
let input = "a (b c)"
|
||||
assertRight (parseTypeQuery input) (QApp (QAny "a") (QApp (QAny "b") (QAny "c")))
|
||||
|
||||
test "test #6.1" do
|
||||
let input = "(a b) (c d)"
|
||||
assertRight (parseTypeQuery input)
|
||||
(QApp (QApp (QAny "a") (QAny "b"))
|
||||
(QApp (QAny "c") (QAny "d")))
|
||||
let input = "a b -> c"
|
||||
assertRight (parseTypeQuery input) (QFun (QApp (QVar "a") (QVar "b")) (QVar "c"))
|
||||
|
||||
test "test #7" do
|
||||
let input = "a ( b c )"
|
||||
assertRight (parseTypeQuery input) (QApp (QAny "a") (QApp (QAny "b") (QAny "c")))
|
||||
let input = "a b"
|
||||
assertRight (parseTypeQuery input) (QApp (QVar "a") (QVar "b"))
|
||||
|
||||
test "test #8" do
|
||||
let input = "aaa"
|
||||
assertRight (parseTypeQuery input) (QAny "aaa")
|
||||
let input = "a (b c)"
|
||||
assertRight (parseTypeQuery input) (QApp (QVar "a") (QApp (QVar "b") (QVar "c")))
|
||||
|
||||
test "test #9" do
|
||||
let input = "aaa ( bbb ccc )"
|
||||
assertRight (parseTypeQuery input) (QApp (QAny "aaa") (QApp (QAny "bbb") (QAny "ccc")))
|
||||
let input = "(a b) (c d)"
|
||||
assertRight (parseTypeQuery input)
|
||||
(QApp (QApp (QVar "a") (QVar "b"))
|
||||
(QApp (QVar "c") (QVar "d")))
|
||||
|
||||
test "test #10" do
|
||||
let input = "(a -> b) -> (c -> d)"
|
||||
assertRight (parseTypeQuery input) (QFun (QFun (QAny "a") (QAny "b"))
|
||||
(QFun (QAny "c") (QAny "d")))
|
||||
let input = "a ( b c )"
|
||||
assertRight (parseTypeQuery input) (QApp (QVar "a") (QApp (QVar "b") (QVar "c")))
|
||||
|
||||
test "test #11" do
|
||||
let input = "a -> b -> c -> d"
|
||||
assertRight (parseTypeQuery input) (QFun (QAny "a")
|
||||
(QFun (QAny "b")
|
||||
(QFun (QAny "c") (QAny "d"))))
|
||||
|
||||
test "test #11.1" do
|
||||
let input = "a -> b -> c"
|
||||
assertRight (parseTypeQuery input) (QFun (QAny "a")
|
||||
(QFun (QAny "b")
|
||||
(QAny "c")))
|
||||
let input = "aaa"
|
||||
assertRight (parseTypeQuery input) (QVar "aaa")
|
||||
|
||||
test "test #12" do
|
||||
let input = "forall a b c. c"
|
||||
assertRight (parseTypeQuery input) (QForAll (nl "a" ["b", "c"]) (QAny "c"))
|
||||
let input = "aaa ( bbb ccc )"
|
||||
assertRight (parseTypeQuery input) (QApp (QVar "aaa") (QApp (QVar "bbb") (QVar "ccc")))
|
||||
|
||||
test "test #13" do
|
||||
let input = "forall a. Maybe a"
|
||||
assertRight (parseTypeQuery input) (QForAll (nl "a" $ []) (QApp (QConcrete "Maybe") (QAny "a")))
|
||||
let input = "(a -> b) -> (c -> d)"
|
||||
assertRight (parseTypeQuery input) (QFun (QFun (QVar "a") (QVar "b"))
|
||||
(QFun (QVar "c") (QVar "d")))
|
||||
|
||||
test "test #14" do
|
||||
let input = "a -> b -> c -> d"
|
||||
assertRight (parseTypeQuery input) (QFun (QVar "a")
|
||||
(QFun (QVar "b")
|
||||
(QFun (QVar "c") (QVar "d"))))
|
||||
|
||||
test "test #15" do
|
||||
let input = "a -> b -> c"
|
||||
assertRight (parseTypeQuery input) (QFun (QVar "a")
|
||||
(QFun (QVar "b")
|
||||
(QVar "c")))
|
||||
|
||||
test "test #16" do
|
||||
let input = "forall a b c. c"
|
||||
assertRight (parseTypeQuery input) (QForAll (nl "a" ["b", "c"]) (QVar "c"))
|
||||
|
||||
test "test #17" do
|
||||
let input = "forall a. Maybe a"
|
||||
assertRight (parseTypeQuery input) (QForAll (nl "a" $ []) (QApp (QConst "Maybe") (QVar "a")))
|
||||
|
||||
test "test #18" do
|
||||
let input = "forall m a. Monad m => a -> m a"
|
||||
assertRight (parseTypeQuery input)
|
||||
(QForAll (nl "m" ["a"])
|
||||
(QConstraint "Monad" (l ["m"])
|
||||
(QFun (QAny "a")
|
||||
(QApp (QAny "m") (QAny "a")))))
|
||||
(QFun (QVar "a")
|
||||
(QApp (QVar "m") (QVar "a")))))
|
||||
|
||||
test "test #15" do
|
||||
test "test #19" do
|
||||
let input = "{ a :: Int }"
|
||||
assertRight (parseTypeQuery input)
|
||||
(QRow (pure (Tuple "a" (QConcrete "Int"))))
|
||||
(QRow (pure (Tuple "a" (QConst "Int"))))
|
||||
|
||||
test "test #16" do
|
||||
test "test #20" do
|
||||
let input = "{a::Int}"
|
||||
assertRight (parseTypeQuery input)
|
||||
(QRow (pure (Tuple "a" (QConcrete "Int"))))
|
||||
(QRow (pure (Tuple "a" (QConst "Int"))))
|
||||
|
||||
test "test #17" do
|
||||
test "test #21" do
|
||||
let input = "Int"
|
||||
assertRight (parseTypeQuery input) (QConcrete "Int")
|
||||
assertRight (parseTypeQuery input) (QConst "Int")
|
||||
|
||||
test "test #18" do
|
||||
test "test #22" do
|
||||
let input = "a->b"
|
||||
assertRight (parseTypeQuery input) (QFun (QAny "a") (QAny "b"))
|
||||
assertRight (parseTypeQuery input) (QFun (QVar "a") (QVar "b"))
|
||||
|
||||
test "test #23" do
|
||||
let input = "forall m a. MonadRec m => Process m a -> m a"
|
||||
assertRight (parseTypeQuery input) (QForAll (nl "m" ("a" : Nil))
|
||||
(QConstraint "MonadRec" ("m" : Nil)
|
||||
(QFun (QApp (QApp (QConst "Process")
|
||||
(QVar "m")) (QVar "a"))
|
||||
(QApp (QVar "m") (QVar "a")))))
|
||||
|
||||
test "test #24" do
|
||||
let input = "forall t f a. Foldable1 t => Apply f => f"
|
||||
assertRight (parseTypeQuery input) (QForAll (nl "t" ["f", "a"])
|
||||
(QConstraint "Foldable1" (l ["t"])
|
||||
(QConstraint "Apply" ("f" : Nil) (QVar "f"))))
|
||||
|
||||
test "test #25" do
|
||||
let input = "forall m a.MonadRec m=>Process m a->m a"
|
||||
assertRight (parseTypeQuery input) ((QForAll (nl "m" ("a" : Nil))
|
||||
(QConstraint "MonadRec" ("m" : Nil)
|
||||
(QFun (QApp (QApp (QConst "Process")
|
||||
(QVar "m")) (QVar "a"))
|
||||
(QApp (QVar "m") (QVar "a"))))))
|
||||
|
||||
suite "polish notation" do
|
||||
|
||||
test "test #1" do
|
||||
let input = "(a -> b) -> (b -> ((a -> b) -> c))"
|
||||
assertRight (shapeOfTypeQuery <$> parseTypeQuery input)
|
||||
(l [ PForAll 3, PFun, PFun, PVar, PVar, PFun, PVar, PFun, PFun
|
||||
, PVar, PVar, PVar ])
|
||||
|
||||
test "test #2" do
|
||||
let input = "forall a. (a -> b) -> (b -> ((a -> b) -> c))"
|
||||
assertRight (shapeOfTypeQuery <$> parseTypeQuery input)
|
||||
(l [ PForAll 3, PFun, PFun, PVar, PVar, PFun, PVar, PFun, PFun
|
||||
, PVar, PVar, PVar ])
|
||||
|
||||
test "test #3" do
|
||||
let input = "forall a. (a -> b) -> (b -> ((a -> b) -> c))"
|
||||
assertRight (shapeOfTypeQuery <$> parseTypeQuery input)
|
||||
(l [ PForAll 3, PFun, PFun, PVar, PVar, PFun, PVar, PFun, PFun
|
||||
, PVar, PVar, PVar ])
|
||||
|
||||
test "test #4" do
|
||||
let input = "forall a. (forall h. ST h (STArray h a)) -> Array a"
|
||||
assertRight (shapeOfTypeQuery <$> parseTypeQuery input)
|
||||
(l [ PForAll 1, PFun, PForAll 1, PApp, PApp, PVar, PVar, PApp, PApp, PVar, PVar, PVar, PApp, PVar, PVar ])
|
||||
|
||||
suite "free variable counting" do
|
||||
|
||||
test "test #1" do
|
||||
let input = "forall a. (a -> b) -> (b -> ((a -> b) -> c))"
|
||||
assertRight (countFreeVars <$> parseTypeQuery input) 2
|
||||
|
||||
test "test #2" do
|
||||
-- `b` is not bound on the left, `a` is not bound on the right
|
||||
let input = "(forall a. (a -> b)) -> forall b. (b -> a)"
|
||||
assertRight (countFreeVars <$> parseTypeQuery input) 2
|
||||
|
||||
test "test #3" do
|
||||
let input = "a -> forall a. a"
|
||||
assertRight (countFreeVars <$> parseTypeQuery input) 1
|
||||
|
||||
test "test #4" do
|
||||
let input = "(forall a. a) -> a"
|
||||
assertRight (countFreeVars <$> parseTypeQuery input) 1
|
||||
|
||||
test "test #5" do
|
||||
let input = "forall a. a -> a"
|
||||
assertRight (countFreeVars <$> parseTypeQuery input) 0
|
||||
|
||||
test "test #6" do
|
||||
let input = "a -> b -> c"
|
||||
assertRight (countFreeVars <$> parseTypeQuery input) 3
|
||||
|
||||
test "test #7" do
|
||||
let input = "forall m a. Monad m => a -> m a"
|
||||
assertRight (countFreeVars <$> parseTypeQuery input) 0
|
||||
|
||||
test "test #8" do
|
||||
let input = "Monad m => a -> m a"
|
||||
assertRight (countFreeVars <$> parseTypeQuery input) 2
|
||||
|
||||
test "test #9" do
|
||||
let input = "Monad m => a -> a"
|
||||
assertRight (countFreeVars <$> parseTypeQuery input) 2
|
||||
|
||||
test "test #10" do
|
||||
let input = "forall a. (forall a. a) a"
|
||||
assertRight (countFreeVars <$> parseTypeQuery input) 0
|
||||
|
||||
test "test #11" do
|
||||
let input = "forall a. (forall b. a) a"
|
||||
assertRight (countFreeVars <$> parseTypeQuery input) 0
|
||||
|
||||
test "test #12" do
|
||||
let input = "forall a. (forall b. a) a b"
|
||||
assertRight (countFreeVars <$> parseTypeQuery input) 1
|
||||
|
||||
l :: forall f. Foldable f => (forall a. f a -> List a)
|
||||
l = List.fromFoldable
|
||||
@ -153,3 +245,6 @@ assertRight eiActual expected =
|
||||
Assert.equal (Right expected) eiActual
|
||||
Right actual -> do
|
||||
Assert.equal (Right expected) eiActual
|
||||
|
||||
countFreeVars :: TypeQuery -> Int
|
||||
countFreeVars = getFreeVariables >>> Set.size
|
||||
|
||||
Loading…
Reference in New Issue
Block a user