mirror of
https://github.com/rowtype-yoga/purescript-docs-search.git
synced 2024-09-11 12:35:37 +03:00
added: proper sorting for type queries
minor UI improvement
This commit is contained in:
parent
410a14eb1f
commit
35bcbe8690
@ -63,6 +63,10 @@ insertStyle doc = do
|
||||
.result__body .keyword, .result__body .syntax {
|
||||
color: #0B71B4;
|
||||
}
|
||||
.badge {
|
||||
/* Add a margin between badge icons and package/module names. */
|
||||
margin-right: 0.25em;
|
||||
}
|
||||
"""
|
||||
mbHead <-
|
||||
ParentNode.querySelector (wrap "head") (Document.toParentNode doc)
|
||||
|
@ -628,5 +628,5 @@ sortByDistance typeQuery results =
|
||||
where
|
||||
comparePenalties r1 r2 = compare r1.penalty r2.penalty
|
||||
resultsWithPenalties = results <#>
|
||||
\result -> { penalty: typeOf (unwrap result).info >>= penalty typeQuery
|
||||
\result -> { penalty: typeOf (unwrap result).info <#> penalty typeQuery
|
||||
, result }
|
||||
|
@ -22,12 +22,14 @@ config =
|
||||
\(partId :: Int) -> "../index/declarations/" <> show partId <> ".js"
|
||||
, resultsCount: 25
|
||||
-- ^ How many results to show by default?
|
||||
, penalties: { typeVars: 2
|
||||
, penalties: { typeVars: 6
|
||||
, match: 2
|
||||
, matchConstraint: 2
|
||||
, instantiate: 3
|
||||
, generalize: 1
|
||||
, matchConstraint: 1
|
||||
, instantiate: 1
|
||||
, generalize: 4
|
||||
, rowsMismatch: 6
|
||||
, mismatch: 10
|
||||
, missingConstraint: 1
|
||||
, excessiveConstraint: 5
|
||||
, excessiveConstraint: 1
|
||||
}
|
||||
}
|
||||
|
@ -9,12 +9,12 @@ import Data.Array ((!!))
|
||||
import Data.Either (Either(..))
|
||||
import Data.Generic.Rep (class Generic)
|
||||
import Data.Generic.Rep.Show (genericShow)
|
||||
import Data.List (List(..), (:))
|
||||
import Data.List as List
|
||||
import Data.Maybe (Maybe(..), fromMaybe)
|
||||
import Data.Newtype (class Newtype)
|
||||
import Data.Tuple (Tuple(..))
|
||||
import Foreign.Object as Object
|
||||
import Data.List (List(..), (:))
|
||||
import Data.List as List
|
||||
|
||||
derive instance eqQualifiedName :: Eq QualifiedName
|
||||
derive instance genericQualifiedName :: Generic QualifiedName _
|
||||
@ -372,3 +372,12 @@ joinRows = go Nil
|
||||
REmpty -> Nothing
|
||||
ty' -> Just ty'
|
||||
}
|
||||
|
||||
-- | Only returns a list of type class names (lists of arguments are omitted).
|
||||
joinConstraints :: Type -> { constraints :: List String
|
||||
, ty :: Type }
|
||||
joinConstraints = go Nil
|
||||
where
|
||||
go acc (ConstrainedType (Constraint { constraintClass: QualifiedName { name } }) ty) =
|
||||
go (name : acc) ty
|
||||
go acc ty = { constraints: List.sort acc, ty }
|
||||
|
@ -11,8 +11,9 @@ where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Docs.Search.TypeDecoder
|
||||
import Docs.Search.Config
|
||||
import Docs.Search.DocsJson
|
||||
import Docs.Search.TypeDecoder
|
||||
|
||||
import Control.Alt ((<|>))
|
||||
import Data.Array as Array
|
||||
@ -183,20 +184,24 @@ data Substitution
|
||||
| Match String String
|
||||
| Generalize TypeQuery String
|
||||
| Substitute String String
|
||||
| MatchConstraints String String
|
||||
| MatchConstraints (Set String) (Set String)
|
||||
| MissingConstraint
|
||||
| ExcessiveConstraint
|
||||
| RowsMismatch Int Int
|
||||
| Mismatch
|
||||
|
||||
derive instance genericSubstitution :: Generic Substitution _
|
||||
|
||||
instance showSubstitution :: Show Substitution where
|
||||
show x = genericShow x
|
||||
|
||||
unify :: TypeQuery -> Type -> Maybe (List Substitution)
|
||||
unify :: TypeQuery -> Type -> List Substitution
|
||||
unify query type_ = go Nil (List.singleton { q: query, t: type_ })
|
||||
where
|
||||
go :: List Substitution -> List { q :: TypeQuery, t :: Type } -> Maybe (List Substitution)
|
||||
go acc Nil = Just acc
|
||||
go :: List Substitution -> List { q :: TypeQuery, t :: Type } -> List Substitution
|
||||
go acc Nil = acc
|
||||
go acc ({ q, t: ParensInType t } : rest) =
|
||||
go acc ({ q, t } : rest)
|
||||
|
||||
-- * ForAll
|
||||
go acc ({ q: (QForAll queryBinders q), t:type_1@(ForAll _ _ _) } : rest) =
|
||||
@ -218,6 +223,16 @@ unify query type_ = go Nil (List.singleton { q: query, t: type_ })
|
||||
-- * Names
|
||||
go acc ({ q: QConst qname, t: TypeConstructor (QualifiedName { name }) } : rest) =
|
||||
go (Match qname name : acc) rest
|
||||
go acc ({ q: QConst qname, t } : rest) =
|
||||
go (Mismatch : acc) rest
|
||||
go acc ({ q, t: TypeConstructor (QualifiedName { name }) } : rest) =
|
||||
go (Mismatch : acc) rest
|
||||
|
||||
-- type operators can't appear in type queries: this is always a mismatch
|
||||
go acc ({ q, t: TypeOp (QualifiedName { name }) } : rest) =
|
||||
go (Mismatch : acc) rest
|
||||
go acc ({ q, t: BinaryNoParensType _ _ _ } : rest) =
|
||||
go (Mismatch : acc) rest
|
||||
|
||||
-- * Functions
|
||||
go acc ({ q: QFun q1 q2
|
||||
@ -225,17 +240,20 @@ unify query type_ = go Nil (List.singleton { q: query, t: type_ })
|
||||
(QualifiedName { moduleName: [ "Prim" ]
|
||||
, name: "Function" })) t1) t2 } : rest) =
|
||||
go acc ({ q: q1, t: t1 } : { q: q2, t: t2 } : rest)
|
||||
go acc ({ q: QFun q1 q2, t } : rest) =
|
||||
go (Mismatch : acc) rest
|
||||
|
||||
-- * Constraints
|
||||
go acc ({ q: QConstraint className args q
|
||||
, t: ConstrainedType cnstr t } : rest) =
|
||||
go (MatchConstraints className typeClassName : acc) ({ q, t } : rest)
|
||||
where typeClassName = (unwrap (unwrap cnstr).constraintClass).name
|
||||
go acc ({ q: QConstraint _ _ q
|
||||
, t } : rest) =
|
||||
go acc ({ q: q@(QConstraint _ _ _)
|
||||
, t: t@(ConstrainedType _ _) } : rest) =
|
||||
let qcs = Set.fromFoldable (joinQueryConstraints q).constraints
|
||||
tcs = Set.fromFoldable (joinConstraints t).constraints
|
||||
in
|
||||
-- TODO: use edit distance instead
|
||||
go (MatchConstraints qcs tcs : acc) rest
|
||||
go acc ({ q: QConstraint _ _ q, t } : rest) =
|
||||
go (ExcessiveConstraint : acc) ({ q, t } : rest)
|
||||
go acc ({ q
|
||||
, t: ConstrainedType cnstr t } : rest) =
|
||||
go acc ({ q, t: ConstrainedType _ t } : rest) =
|
||||
go (MissingConstraint : acc) ({ q, t } : rest)
|
||||
|
||||
-- * Rows
|
||||
@ -243,25 +261,45 @@ unify query type_ = go Nil (List.singleton { q: query, t: type_ })
|
||||
, t: TypeApp (TypeConstructor
|
||||
(QualifiedName { moduleName: [ "Prim" ]
|
||||
, name: "Record" })) row } : rest) =
|
||||
let { rows, ty } = joinRows row in
|
||||
if List.length rows == List.length qRows then
|
||||
let { rows, ty } = joinRows row
|
||||
qRowsLength = List.length qRows
|
||||
rowsLength = List.length rows in
|
||||
if rowsLength == qRowsLength then
|
||||
let
|
||||
sortedQRows = List.sortBy (\x y -> compare (fst x) (fst y)) qRows
|
||||
sortedRows = List.sortBy (\x y -> compare x.row y.row) rows in
|
||||
go acc $
|
||||
(List.zipWith (\(Tuple _ q) { ty: t } -> { q, t }) sortedQRows sortedRows <> rest)
|
||||
go
|
||||
-- match row names
|
||||
(List.zipWith (\(Tuple qRowName _) { row: rowName } ->
|
||||
Match qRowName rowName) sortedQRows sortedRows <> acc)
|
||||
-- match row types
|
||||
(List.zipWith (\(Tuple _ q) { ty: t } ->
|
||||
{ q, t }) sortedQRows sortedRows <> rest)
|
||||
else
|
||||
Nothing
|
||||
go (RowsMismatch qRowsLength rowsLength : acc) rest
|
||||
|
||||
go acc ({ q: QRow _ } : rest) =
|
||||
go (Mismatch : acc) rest
|
||||
|
||||
-- * Type application
|
||||
go acc ({ q: QApp q1 q2, t: TypeApp t1 t2 } : rest) =
|
||||
go acc ({ q: q1, t: t1 } : { q: q2, t: t2 } : rest)
|
||||
|
||||
go acc _ = Nothing
|
||||
go acc ({ q, t: TypeLevelString _ } : rest) =
|
||||
go (Mismatch : acc) rest
|
||||
|
||||
penalty :: TypeQuery -> Type -> Maybe Int
|
||||
go acc ({ q, t: TypeWildcard } : rest) =
|
||||
go (Mismatch : acc) rest
|
||||
|
||||
go acc ({ q, t: RCons _ _ _ } : rest) =
|
||||
go (Mismatch : acc) rest
|
||||
|
||||
go acc ({ q, t: REmpty } : rest) =
|
||||
go (Mismatch : acc) rest
|
||||
|
||||
penalty :: TypeQuery -> Type -> Int
|
||||
penalty typeQuery ty =
|
||||
unify typeQuery ty <#> \substs ->
|
||||
let substs = unify typeQuery ty in
|
||||
typeVarPenalty substs * config.penalties.typeVars +
|
||||
namesPenalty substs +
|
||||
mismatchPenalty substs
|
||||
@ -293,14 +331,17 @@ typeVarPenalty substs =
|
||||
namesPenalty :: List Substitution -> Int
|
||||
namesPenalty = go 0
|
||||
where
|
||||
go n Nil = n
|
||||
go n (Match a b : rest)
|
||||
| a == b = go n rest
|
||||
| otherwise = go (n + config.penalties.match) rest
|
||||
go n (MatchConstraints a b : rest)
|
||||
| a == b = go n rest
|
||||
| otherwise = go (n + config.penalties.matchConstraint) rest
|
||||
go n (_ : rest) = go n rest
|
||||
go p Nil = p
|
||||
go p (Mismatch : rest) = go (p + config.penalties.mismatch) rest
|
||||
go p (Match a b : rest)
|
||||
| a == b = go p rest
|
||||
| otherwise = go (p + config.penalties.match) rest
|
||||
go p (MatchConstraints qcs tcs : rest)
|
||||
= let p' = Set.size (Set.union qcs tcs) -
|
||||
Set.size (Set.intersection qcs tcs) in
|
||||
go (p + config.penalties.matchConstraint * p') rest
|
||||
go p (RowsMismatch n m : rest) = go (config.penalties.rowsMismatch * abs (n - m)) rest
|
||||
go p (_ : rest) = go p rest
|
||||
|
||||
-- | Penalty for generalization and instantiation.
|
||||
mismatchPenalty :: List Substitution -> Int
|
||||
@ -312,3 +353,12 @@ mismatchPenalty = go 0
|
||||
go n (ExcessiveConstraint : rest) = go (n + config.penalties.excessiveConstraint) rest
|
||||
go n (MissingConstraint : rest) = go (n + config.penalties.missingConstraint) rest
|
||||
go n (_ : rest) = go n rest
|
||||
|
||||
-- | Only returns a list of type class names (lists of arguments are omitted).
|
||||
joinQueryConstraints :: TypeQuery -> { constraints :: List String
|
||||
, ty :: TypeQuery }
|
||||
joinQueryConstraints = go Nil
|
||||
where
|
||||
go acc (QConstraint name _ query) =
|
||||
go (name : acc) query
|
||||
go acc ty = { constraints: List.sort acc, ty }
|
||||
|
@ -2,9 +2,9 @@ module Test.TypeQuery where
|
||||
|
||||
import Prelude
|
||||
|
||||
|
||||
import Docs.Search.TypeQuery (TypeQuery(..), Substitution(..), getFreeVariables, parseTypeQuery, typeVarPenalty)
|
||||
import Docs.Search.TypeQuery (Substitution(..), TypeQuery(..), getFreeVariables, parseTypeQuery, penalty, typeVarPenalty)
|
||||
import Docs.Search.TypeShape (ShapeChunk(..), shapeOfTypeQuery)
|
||||
import Docs.Search.TypeDecoder (QualifiedName(..), Type(..))
|
||||
|
||||
import Data.Either (Either(..))
|
||||
import Data.Foldable (class Foldable)
|
||||
@ -195,6 +195,15 @@ tests = do
|
||||
, Tuple "row2" (QRow Nil)
|
||||
, Tuple "row3" (QRow (l [ Tuple "row4" (QApp (QConst "Record") (QRow Nil)) ])) ]))
|
||||
|
||||
test "test #33" do
|
||||
let input = "Foldable1 t => Apply f => t (f a) -> f Unit"
|
||||
assertRight (parseTypeQuery input)
|
||||
(QConstraint "Foldable1" ((QVar "t") : Nil) (QConstraint "Apply" ((QVar "f") : Nil) (QFun (QApp (QVar "t") (QApp (QVar "f") (QVar "a"))) (QApp (QVar "f") (QConst "Unit")))))
|
||||
|
||||
test "test #34" do
|
||||
let input = "Foldable1 t => Apply f => t (f a) -> f a"
|
||||
assertRight (parseTypeQuery input)
|
||||
(QConstraint "Foldable1" ((QVar "t") : Nil) (QConstraint "Apply" ((QVar "f") : Nil) (QFun (QApp (QVar "t") (QApp (QVar "f") (QVar "a"))) (QApp (QVar "f") (QVar "a")))))
|
||||
|
||||
suite "polish notation" do
|
||||
|
||||
@ -332,12 +341,33 @@ tests = do
|
||||
, Substitute "c" "f"
|
||||
])
|
||||
|
||||
suite "unification" do
|
||||
test "instantiation #0" do
|
||||
let mVarQuery = QVar "m"
|
||||
unitConstQuery = QConst "Unit"
|
||||
|
||||
Assert.assert "instantiation #0" $
|
||||
(penalty unitConstQuery unitType < penalty mVarQuery unitType)
|
||||
|
||||
test "generalization #0" do
|
||||
let query = QVar "m"
|
||||
t1 = TypeVar "m"
|
||||
|
||||
Assert.assert "qeneralization #0" $
|
||||
(penalty query unitType > penalty query t1)
|
||||
|
||||
|
||||
l :: forall f. Foldable f => (forall a. f a -> List a)
|
||||
l = List.fromFoldable
|
||||
|
||||
nl :: forall t5 t6. Foldable t6 => t5 -> t6 t5 -> NonEmptyList t5
|
||||
nl x rst = NonEmptyList.cons' x $ List.fromFoldable rst
|
||||
|
||||
unitType :: Type
|
||||
unitType = TypeConstructor (QualifiedName { moduleName: []
|
||||
, name: "Unit"
|
||||
})
|
||||
|
||||
assertRight
|
||||
:: forall a b
|
||||
. Show a
|
||||
|
Loading…
Reference in New Issue
Block a user