mirror of
https://github.com/rowtype-yoga/purescript-docs-search.git
synced 2024-09-11 12:35:37 +03:00
Wrap package scores and identifiers in newtypes
This commit is contained in:
parent
fd2b46e83b
commit
d502fcefc8
@ -6,7 +6,7 @@ import Docs.Search.BrowserEngine (PartialIndex, browserSearchEngine)
|
||||
import Docs.Search.Config (config)
|
||||
import Docs.Search.Declarations (DeclLevel(..), declLevelToHashAnchor)
|
||||
import Docs.Search.DocsJson (DataDeclType(..))
|
||||
import Docs.Search.Engine (Result(..))
|
||||
import Docs.Search.Engine (Result(..), packageInfoToString)
|
||||
import Docs.Search.Engine as Engine
|
||||
import Docs.Search.Extra (homePageFromRepository, (>#>))
|
||||
import Docs.Search.ModuleIndex (ModuleResult)
|
||||
@ -14,7 +14,7 @@ import Docs.Search.PackageIndex (PackageResult)
|
||||
import Docs.Search.SearchResult (ResultInfo(..), SearchResult(..))
|
||||
import Docs.Search.TypeDecoder (Constraint(..), FunDep(..), FunDeps(..), Kind(..), QualifiedName(..), Type(..), TypeArgument(..), joinForAlls, joinRows)
|
||||
import Docs.Search.TypeIndex (TypeIndex)
|
||||
import Docs.Search.Types (ModuleName(..), packageInfoToString)
|
||||
import Docs.Search.Types (ModuleName(..), Identifier(..))
|
||||
|
||||
import Prelude
|
||||
|
||||
@ -302,9 +302,9 @@ renderSearchResult markdownIt (SearchResult result) =
|
||||
, HE.onClick $ const $ Just $ SearchResultClicked result.moduleName
|
||||
, HP.href $
|
||||
unwrap result.moduleName <> ".html#" <>
|
||||
result.hashAnchor <> ":" <> result.name
|
||||
result.hashAnchor <> ":" <> unwrap result.name
|
||||
]
|
||||
[ HH.text result.name ]
|
||||
[ HH.text $ unwrap result.name ]
|
||||
]
|
||||
]
|
||||
|
||||
@ -341,7 +341,7 @@ renderSearchResult markdownIt (SearchResult result) =
|
||||
renderResultType
|
||||
:: forall a rest
|
||||
. { info :: ResultInfo
|
||||
, name :: String
|
||||
, name :: Identifier
|
||||
, moduleName :: ModuleName
|
||||
| rest
|
||||
}
|
||||
@ -373,7 +373,7 @@ renderResultType result =
|
||||
renderValueSignature
|
||||
:: forall a rest
|
||||
. { moduleName :: ModuleName
|
||||
, name :: String
|
||||
, name :: Identifier
|
||||
| rest
|
||||
}
|
||||
-> Type
|
||||
@ -381,7 +381,7 @@ renderValueSignature
|
||||
renderValueSignature result ty =
|
||||
[ HH.a [ makeHref ValueLevel false result.moduleName result.name
|
||||
, HE.onClick $ const $ Just $ SearchResultClicked result.moduleName ]
|
||||
[ HH.text result.name ]
|
||||
[ HH.text $ unwrap result.name ]
|
||||
, HH.text " :: "
|
||||
, renderType ty ]
|
||||
|
||||
@ -392,7 +392,7 @@ renderTypeClassSignature
|
||||
, arguments :: Array TypeArgument
|
||||
, superclasses :: Array Constraint
|
||||
}
|
||||
-> { name :: String, moduleName :: ModuleName | rest }
|
||||
-> { name :: Identifier, moduleName :: ModuleName | rest }
|
||||
-> Array (HH.HTML a Action)
|
||||
renderTypeClassSignature { fundeps, arguments, superclasses } { name, moduleName } =
|
||||
[ keyword "class"
|
||||
@ -414,7 +414,7 @@ renderTypeClassSignature { fundeps, arguments, superclasses } { name, moduleName
|
||||
, HE.onClick $ const $ Just $
|
||||
SearchResultClicked moduleName
|
||||
]
|
||||
[ HH.text name ]
|
||||
[ HH.text $ unwrap name ]
|
||||
, space
|
||||
] <> (
|
||||
Array.intercalate [ space ] $
|
||||
@ -444,10 +444,10 @@ renderTypeClassMemberSignature
|
||||
, typeClass :: QualifiedName
|
||||
, typeClassArguments :: Array TypeArgument
|
||||
}
|
||||
-> { name :: String | rest }
|
||||
-> { name :: Identifier | rest }
|
||||
-> Array (HH.HTML a Action)
|
||||
renderTypeClassMemberSignature { type: ty, typeClass, typeClassArguments } result =
|
||||
[ HH.text result.name
|
||||
[ HH.text $ unwrap result.name
|
||||
, HH.text " :: "
|
||||
, renderType ty
|
||||
]
|
||||
@ -457,7 +457,7 @@ renderDataSignature
|
||||
:: forall a rest
|
||||
. { typeArguments :: Array TypeArgument
|
||||
, dataDeclType :: DataDeclType }
|
||||
-> { name :: String | rest }
|
||||
-> { name :: Identifier | rest }
|
||||
-> Array (HH.HTML a Action)
|
||||
renderDataSignature { typeArguments, dataDeclType } { name } =
|
||||
[ keyword
|
||||
@ -465,7 +465,7 @@ renderDataSignature { typeArguments, dataDeclType } { name } =
|
||||
NewtypeDataDecl -> "newtype"
|
||||
DataDataDecl -> "data"
|
||||
, space
|
||||
, HH.text name
|
||||
, HH.text $ unwrap name
|
||||
, space
|
||||
, HH.span_ $
|
||||
Array.intercalate [ space ] $
|
||||
@ -478,12 +478,12 @@ renderTypeSynonymSignature
|
||||
. { type :: Type
|
||||
, arguments :: Array TypeArgument
|
||||
}
|
||||
-> { name :: String | rest }
|
||||
-> { name :: Identifier | rest }
|
||||
-> Array (HH.HTML a Action)
|
||||
renderTypeSynonymSignature { type: ty, arguments } { name } =
|
||||
[ keyword "type"
|
||||
, space
|
||||
, HH.text name
|
||||
, HH.text $ unwrap name
|
||||
, space
|
||||
, HH.span_ $
|
||||
Array.intercalate [ space ] $
|
||||
@ -499,10 +499,10 @@ renderTypeArgument :: forall a. TypeArgument -> Array (HH.HTML a Action)
|
||||
renderTypeArgument (TypeArgument { name, mbKind }) =
|
||||
case mbKind of
|
||||
Nothing ->
|
||||
[ HH.text name ]
|
||||
[ HH.text $ name ]
|
||||
Just kind ->
|
||||
[ HH.text "("
|
||||
, HH.text name
|
||||
, HH.text $ name
|
||||
, HH.text " :: "
|
||||
, renderKind kind
|
||||
, HH.text ")"
|
||||
@ -522,14 +522,14 @@ renderType = case _ of
|
||||
|
||||
TypeApp (TypeApp (TypeConstructor
|
||||
(QualifiedName { moduleNameParts: [ "Prim" ]
|
||||
, name: "Function" })) t1) t2 ->
|
||||
, name: Identifier "Function" })) t1) t2 ->
|
||||
HH.span_ [ renderType t1
|
||||
, syntax " -> "
|
||||
, renderType t2
|
||||
]
|
||||
|
||||
TypeApp (TypeConstructor (QualifiedName { moduleNameParts: [ "Prim" ]
|
||||
, name: "Record" }))
|
||||
, name: Identifier "Record" }))
|
||||
row ->
|
||||
renderRow false row
|
||||
|
||||
@ -624,7 +624,7 @@ renderRow asRow =
|
||||
|
||||
( Array.intercalate [ HH.text ", " ] $ Array.fromFoldable $ rows <#>
|
||||
\entry ->
|
||||
[ HH.span_ [ HH.text $ entry.row <> " :: "
|
||||
[ HH.span_ [ HH.text $ unwrap entry.row <> " :: "
|
||||
, renderType entry.ty ] ]
|
||||
) <>
|
||||
|
||||
@ -637,7 +637,7 @@ renderRow asRow =
|
||||
closing = if asRow then " )" else " }"
|
||||
|
||||
primRecord :: QualifiedName
|
||||
primRecord = QualifiedName { moduleNameParts: [ "Prim" ], name: "Record" }
|
||||
primRecord = QualifiedName { moduleNameParts: [ "Prim" ], name: Identifier "Record" }
|
||||
|
||||
|
||||
renderConstraint
|
||||
@ -658,13 +658,13 @@ renderQualifiedName
|
||||
-> HH.HTML a Action
|
||||
renderQualifiedName isInfix level (QualifiedName { moduleNameParts, name })
|
||||
= if isBuiltIn then
|
||||
HH.text name
|
||||
HH.text $ unwrap name
|
||||
else
|
||||
HH.a [ HE.onClick $ const $ Just $
|
||||
SearchResultClicked $ moduleName
|
||||
, makeHref level isInfix moduleName name
|
||||
]
|
||||
[ HH.text name ]
|
||||
[ HH.text $ unwrap name ]
|
||||
where
|
||||
moduleName = ModuleName $ Array.intercalate "." $ moduleNameParts
|
||||
isBuiltIn = moduleNameParts !! 0 == Just "Prim"
|
||||
@ -686,13 +686,13 @@ makeHref
|
||||
. DeclLevel
|
||||
-> Boolean
|
||||
-> ModuleName
|
||||
-> String
|
||||
-> Identifier
|
||||
-> HH.IProp ( href :: String | rest ) t
|
||||
makeHref level isInfix moduleName name =
|
||||
HP.href $
|
||||
unwrap moduleName <> ".html#" <>
|
||||
declLevelToHashAnchor level <> ":" <>
|
||||
if isInfix then "type (" <> name <> ")" else name
|
||||
if isInfix then "type (" <> unwrap name <> ")" else unwrap name
|
||||
|
||||
|
||||
keyword
|
||||
|
@ -4,7 +4,7 @@ import Docs.Search.DocsJson (ChildDeclType(..), ChildDeclaration(..), DeclType(.
|
||||
import Docs.Search.Score (Scores, getPackageScore, getPackageScoreForPackageName)
|
||||
import Docs.Search.SearchResult (ResultInfo(..), SearchResult(..))
|
||||
import Docs.Search.TypeDecoder (Constraint(..), QualifiedName(..), Type(..), Kind, joinForAlls)
|
||||
import Docs.Search.Types (ModuleName(..), PackageName(..), PackageInfo(..))
|
||||
import Docs.Search.Types (ModuleName(..), PackageName(..), PackageInfo(..), Identifier(..))
|
||||
|
||||
import Prelude
|
||||
|
||||
@ -83,14 +83,14 @@ resultsForDeclaration scores moduleName indexEntry@(Declaration entry) =
|
||||
case mkInfo declLevel indexEntry of
|
||||
Nothing -> mempty
|
||||
Just info' ->
|
||||
let result = SearchResult { name: title
|
||||
let result = SearchResult { name: Identifier title
|
||||
, comments
|
||||
, hashAnchor: declLevelToHashAnchor declLevel
|
||||
, moduleName
|
||||
, sourceSpan
|
||||
, packageInfo
|
||||
, score:
|
||||
fromMaybe 0 $ getPackageScoreForPackageName scores <$> mbPackageName
|
||||
fromMaybe zero $ getPackageScoreForPackageName scores <$> mbPackageName
|
||||
, info: info'
|
||||
}
|
||||
in
|
||||
@ -219,7 +219,7 @@ resultsForChildDeclaration scores packageInfo moduleName parentResult
|
||||
child@(ChildDeclaration { title, info, comments, mbSourceSpan })
|
||||
| Just resultInfo <- mkChildInfo parentResult child =
|
||||
{ path: title
|
||||
, result: SearchResult { name: title
|
||||
, result: SearchResult { name: Identifier title
|
||||
, comments
|
||||
-- `ChildDeclaration`s are always either data
|
||||
-- constructors, type class members or instances.
|
||||
|
@ -5,7 +5,7 @@ import Docs.Search.PackageIndex (PackageIndex, PackageResult)
|
||||
import Docs.Search.Score (Scores)
|
||||
import Docs.Search.SearchResult (SearchResult, typeOfResult)
|
||||
import Docs.Search.TypeQuery (TypeQuery(..), parseTypeQuery, penalty)
|
||||
import Docs.Search.Types (PackageInfo(..), PackageName(..), ModuleName(..))
|
||||
import Docs.Search.Types (PackageInfo(..), ModuleName(..), PackageName(..), PackageScore)
|
||||
|
||||
import Prelude
|
||||
|
||||
@ -66,7 +66,7 @@ data Result
|
||||
| MdlResult ModuleResult
|
||||
|
||||
|
||||
getResultScore :: Result -> Int
|
||||
getResultScore :: Result -> PackageScore
|
||||
getResultScore (DeclResult r) = (unwrap r).score
|
||||
getResultScore (TypeResult r) = (unwrap r).score
|
||||
getResultScore (PackResult r) = r.score
|
||||
@ -88,8 +88,8 @@ getResultModuleName (MdlResult r) = r.name
|
||||
|
||||
|
||||
getResultName :: Result -> String
|
||||
getResultName (DeclResult r) = (unwrap r).name
|
||||
getResultName (TypeResult r) = (unwrap r).name
|
||||
getResultName (DeclResult r) = unwrap (unwrap r).name
|
||||
getResultName (TypeResult r) = unwrap (unwrap r).name
|
||||
getResultName (PackResult r) = unwrap r.name
|
||||
getResultName (MdlResult r) = unwrap r.name
|
||||
|
||||
@ -158,3 +158,10 @@ sortByDistance
|
||||
-> Array SearchResult
|
||||
sortByDistance typeQuery =
|
||||
Array.sortWith (map (penalty typeQuery) <<< typeOfResult)
|
||||
|
||||
|
||||
packageInfoToString :: PackageInfo -> String
|
||||
packageInfoToString (Package (PackageName p)) = p
|
||||
packageInfoToString Builtin = "<builtin>"
|
||||
packageInfoToString LocalPackage = "<local package>"
|
||||
packageInfoToString UnknownPackage = "<unknown package>"
|
||||
|
@ -3,7 +3,7 @@ module Docs.Search.Interactive where
|
||||
|
||||
import Docs.Search.Declarations (Declarations, mkDeclarations)
|
||||
import Docs.Search.DocsJson (DataDeclType(..))
|
||||
import Docs.Search.Engine (mkEngineState, Result(..))
|
||||
import Docs.Search.Engine (mkEngineState, packageInfoToString, Result(..))
|
||||
import Docs.Search.Engine as Engine
|
||||
import Docs.Search.Extra (listToString, stringToList, (>#>))
|
||||
import Docs.Search.IndexBuilder as IndexBuilder
|
||||
@ -16,7 +16,7 @@ import Docs.Search.Terminal (bold, cyan, green, yellow)
|
||||
import Docs.Search.TypeDecoder (Constraint, FunDeps, Kind, QualifiedName, Type, TypeArgument)
|
||||
import Docs.Search.TypeIndex (resultsWithTypes)
|
||||
import Docs.Search.TypePrinter (keyword, showConstraint, showFunDeps, showKind, showType, showTypeArgument, space, syntax)
|
||||
import Docs.Search.Types (PackageName, ModuleName, PackageInfo, packageInfoToString)
|
||||
import Docs.Search.Types (ModuleName, PackageInfo, Identifier)
|
||||
|
||||
import Prelude
|
||||
|
||||
@ -150,19 +150,19 @@ showModuleResult { name, package } =
|
||||
bold (cyan "module") <> " " <> bold (green $ unwrap name)
|
||||
|
||||
|
||||
showSignature ::
|
||||
forall rest.
|
||||
{ name :: String
|
||||
, moduleName :: ModuleName
|
||||
, packageInfo :: PackageInfo
|
||||
, info :: ResultInfo
|
||||
| rest
|
||||
}
|
||||
showSignature
|
||||
:: forall rest
|
||||
. { name :: Identifier
|
||||
, moduleName :: ModuleName
|
||||
, packageInfo :: PackageInfo
|
||||
, info :: ResultInfo
|
||||
| rest
|
||||
}
|
||||
-> String
|
||||
showSignature result@{ name, info } =
|
||||
case info of
|
||||
ValueResult { type: ty } ->
|
||||
yellow name <> syntax " :: " <> showType ty
|
||||
yellow (unwrap name) <> syntax " :: " <> showType ty
|
||||
|
||||
TypeClassResult info' ->
|
||||
showTypeClassSignature info' result
|
||||
@ -180,9 +180,9 @@ showSignature result@{ name, info } =
|
||||
showExternDataSignature info' result
|
||||
|
||||
ValueAliasResult ->
|
||||
yellow ("(" <> name <> ")")
|
||||
yellow ("(" <> unwrap name <> ")")
|
||||
|
||||
_ -> yellow name
|
||||
_ -> yellow $ unwrap name
|
||||
|
||||
|
||||
showTypeClassSignature
|
||||
@ -191,7 +191,7 @@ showTypeClassSignature
|
||||
, arguments :: Array TypeArgument
|
||||
, superclasses :: Array Constraint
|
||||
}
|
||||
-> { name :: String, moduleName :: ModuleName | rest }
|
||||
-> { name :: Identifier, moduleName :: ModuleName | rest }
|
||||
-> String
|
||||
showTypeClassSignature { fundeps, arguments, superclasses } { name, moduleName } =
|
||||
|
||||
@ -210,7 +210,7 @@ showTypeClassSignature { fundeps, arguments, superclasses } { name, moduleName }
|
||||
syntax "<="
|
||||
) <>
|
||||
space <>
|
||||
yellow name <>
|
||||
yellow (unwrap name) <>
|
||||
space <> (
|
||||
Array.intercalate space $
|
||||
arguments <#> showTypeArgument
|
||||
@ -221,14 +221,14 @@ showTypeClassSignature { fundeps, arguments, superclasses } { name, moduleName }
|
||||
|
||||
showTypeClassMemberSignature
|
||||
:: forall rest
|
||||
. { type :: Type
|
||||
. { "type" :: Type
|
||||
, typeClass :: QualifiedName
|
||||
, typeClassArguments :: Array TypeArgument
|
||||
}
|
||||
-> { name :: String | rest }
|
||||
-> { name :: Identifier | rest }
|
||||
-> String
|
||||
showTypeClassMemberSignature { type: ty, typeClass, typeClassArguments } result =
|
||||
yellow result.name <>
|
||||
showTypeClassMemberSignature { "type": ty, typeClass, typeClassArguments } result =
|
||||
yellow (unwrap result.name) <>
|
||||
syntax " :: " <>
|
||||
showType ty
|
||||
|
||||
@ -237,7 +237,7 @@ showDataSignature
|
||||
:: forall rest
|
||||
. { typeArguments :: Array TypeArgument
|
||||
, dataDeclType :: DataDeclType }
|
||||
-> { name :: String | rest }
|
||||
-> { name :: Identifier | rest }
|
||||
-> String
|
||||
showDataSignature { typeArguments, dataDeclType } { name } =
|
||||
( keyword
|
||||
@ -246,7 +246,7 @@ showDataSignature { typeArguments, dataDeclType } { name } =
|
||||
DataDataDecl -> "data"
|
||||
) <>
|
||||
space <>
|
||||
yellow name <>
|
||||
yellow (unwrap name) <>
|
||||
space <> (
|
||||
Array.intercalate space $
|
||||
typeArguments <#> showTypeArgument
|
||||
@ -258,12 +258,12 @@ showTypeSynonymSignature
|
||||
. { type :: Type
|
||||
, arguments :: Array TypeArgument
|
||||
}
|
||||
-> { name :: String | rest }
|
||||
-> { name :: Identifier | rest }
|
||||
-> String
|
||||
showTypeSynonymSignature { type: ty, arguments } { name } =
|
||||
keyword "type" <>
|
||||
space <>
|
||||
yellow name <>
|
||||
yellow (unwrap name) <>
|
||||
space <> (
|
||||
Array.intercalate space $
|
||||
arguments <#> showTypeArgument
|
||||
@ -277,12 +277,12 @@ showTypeSynonymSignature { type: ty, arguments } { name } =
|
||||
showExternDataSignature
|
||||
:: forall rest
|
||||
. { kind :: Kind }
|
||||
-> { name :: String | rest }
|
||||
-> { name :: Identifier | rest }
|
||||
-> String
|
||||
showExternDataSignature { kind } { name } =
|
||||
keyword "foreign data" <>
|
||||
space <>
|
||||
yellow name <>
|
||||
yellow (unwrap name) <>
|
||||
space <>
|
||||
syntax " :: " <>
|
||||
showKind kind
|
||||
|
@ -3,9 +3,9 @@ module Docs.Search.ModuleIndex where
|
||||
import Docs.Search.Config (config)
|
||||
import Docs.Search.Declarations (Declarations(..))
|
||||
import Docs.Search.SearchResult (SearchResult(..))
|
||||
import Docs.Search.Types (ModuleName, PackageName, PackageInfo(..))
|
||||
import Docs.Search.Types (ModuleName, PackageName, PackageInfo(..), PackageScore)
|
||||
import Docs.Search.Extra (stringToList)
|
||||
import Docs.Search.Score (Scores)
|
||||
import Docs.Search.Score (Scores, getPackageScoreForPackageName)
|
||||
|
||||
import Prelude
|
||||
|
||||
@ -50,7 +50,7 @@ type ModuleIndex = { packageModules :: Map PackageName (Set ModuleName)
|
||||
type ModuleResult
|
||||
= { name :: ModuleName
|
||||
, package :: PackageName
|
||||
, score :: Int
|
||||
, score :: PackageScore
|
||||
}
|
||||
|
||||
|
||||
@ -86,7 +86,8 @@ queryModuleIndex scores { index, modulePackages } query =
|
||||
Array.nub <#>
|
||||
(\name -> do
|
||||
package <- Map.lookup name modulePackages
|
||||
pure { name, package, score: fromMaybe 0 $ Map.lookup package scores }) #
|
||||
pure { name, package
|
||||
, score: getPackageScoreForPackageName scores package }) #
|
||||
Array.catMaybes
|
||||
|
||||
|
||||
|
@ -3,7 +3,7 @@ module Docs.Search.PackageIndex where
|
||||
import Docs.Search.Config (config)
|
||||
import Docs.Search.Extra (stringToList)
|
||||
import Docs.Search.Score (Scores, getPackageScoreForPackageName, normalizePackageName)
|
||||
import Docs.Search.Types (PackageName, RawPackageName(..))
|
||||
import Docs.Search.Types (PackageName, RawPackageName(..), PackageScore)
|
||||
|
||||
import Prelude
|
||||
|
||||
@ -26,7 +26,7 @@ import Web.Bower.PackageMeta (PackageMeta(..))
|
||||
type PackageResult
|
||||
= { name :: PackageName
|
||||
, description :: Maybe String
|
||||
, score :: Int
|
||||
, score :: PackageScore
|
||||
, dependencies :: Array PackageName
|
||||
, repository :: Maybe String
|
||||
}
|
||||
|
@ -1,6 +1,6 @@
|
||||
module Docs.Search.Score where
|
||||
|
||||
import Docs.Search.Types (RawPackageName(..), PackageName(..), PackageInfo(..))
|
||||
import Docs.Search.Types (RawPackageName(..), PackageName(..), PackageInfo(..), PackageScore(..))
|
||||
|
||||
import Prelude
|
||||
|
||||
@ -13,7 +13,7 @@ import Data.String.CodeUnits as String
|
||||
import Web.Bower.PackageMeta (Dependencies, PackageMeta)
|
||||
|
||||
|
||||
type Scores = Map PackageName Int
|
||||
type Scores = Map PackageName PackageScore
|
||||
|
||||
normalizePackageName :: RawPackageName -> PackageName
|
||||
normalizePackageName (RawPackageName p) =
|
||||
@ -35,18 +35,18 @@ mkScores =
|
||||
updateScoresFor :: Dependencies -> Scores -> Scores
|
||||
updateScoresFor deps scores =
|
||||
Array.foldr
|
||||
(\dep -> Map.insertWith add dep 1)
|
||||
(\dep -> Map.insertWith add dep one)
|
||||
scores
|
||||
(deps # unwrap >>> map (_.packageName >>> RawPackageName >>> normalizePackageName))
|
||||
|
||||
|
||||
getPackageScore :: Scores -> PackageInfo -> Int
|
||||
getPackageScore :: Scores -> PackageInfo -> PackageScore
|
||||
getPackageScore scores = case _ of
|
||||
Package p -> getPackageScoreForPackageName scores p
|
||||
Builtin -> 100000
|
||||
LocalPackage -> 200000
|
||||
UnknownPackage -> 0
|
||||
Builtin -> PackageScore 100000
|
||||
LocalPackage -> PackageScore 200000
|
||||
UnknownPackage -> zero
|
||||
|
||||
|
||||
getPackageScoreForPackageName :: Scores -> PackageName -> Int
|
||||
getPackageScoreForPackageName scores p = fromMaybe 0 $ Map.lookup p scores
|
||||
getPackageScoreForPackageName :: Scores -> PackageName -> PackageScore
|
||||
getPackageScoreForPackageName scores p = fromMaybe zero $ Map.lookup p scores
|
||||
|
@ -2,7 +2,7 @@ module Docs.Search.SearchResult where
|
||||
|
||||
import Docs.Search.DocsJson (DataDeclType)
|
||||
import Docs.Search.TypeDecoder (Constraint, FunDeps, Kind, QualifiedName, Type, TypeArgument)
|
||||
import Docs.Search.Types (PackageName, PackageInfo, ModuleName)
|
||||
import Docs.Search.Types (ModuleName, PackageInfo, Identifier, PackageScore)
|
||||
|
||||
import Prelude
|
||||
|
||||
@ -57,12 +57,12 @@ typeOf _ = Nothing
|
||||
-- | Common metadata for all types of search results.
|
||||
newtype SearchResult
|
||||
= SearchResult
|
||||
{ name :: String
|
||||
{ name :: Identifier
|
||||
, comments :: Maybe String
|
||||
, hashAnchor :: String
|
||||
, moduleName :: ModuleName
|
||||
, packageInfo :: PackageInfo
|
||||
, score :: Int
|
||||
, score :: PackageScore
|
||||
, sourceSpan :: Maybe { start :: Array Int
|
||||
, end :: Array Int
|
||||
, name :: String
|
||||
|
@ -1,5 +1,7 @@
|
||||
module Docs.Search.TypeDecoder where
|
||||
|
||||
import Docs.Search.Types (Identifier)
|
||||
|
||||
import Prelude
|
||||
|
||||
import Control.Alt ((<|>))
|
||||
@ -26,7 +28,7 @@ instance showQualifiedName :: Show QualifiedName where
|
||||
|
||||
newtype QualifiedName
|
||||
= QualifiedName { moduleNameParts :: Array String
|
||||
, name :: String
|
||||
, name :: Identifier
|
||||
}
|
||||
|
||||
instance decodeJsonQualifiedName :: DecodeJson QualifiedName where
|
||||
@ -149,7 +151,7 @@ data Type
|
||||
-- | An empty row
|
||||
| REmpty
|
||||
-- | A non-empty row
|
||||
| RCons String Type Type
|
||||
| RCons Identifier Type Type
|
||||
{-
|
||||
-- | A type with a kind annotation
|
||||
| Kinded Type Kind
|
||||
@ -412,7 +414,7 @@ joinForAlls ty = go Nil ty
|
||||
go ({ name, mbKind } : acc) ty'
|
||||
go acc ty' = { binders: acc, ty: ty' }
|
||||
|
||||
joinRows :: Type -> { rows :: List { row :: String
|
||||
joinRows :: Type -> { rows :: List { row :: Identifier
|
||||
, ty :: Type
|
||||
}
|
||||
, ty :: Maybe Type }
|
||||
@ -428,7 +430,7 @@ joinRows = go Nil
|
||||
}
|
||||
|
||||
-- | Only returns a list of type class names (lists of arguments are omitted).
|
||||
joinConstraints :: Type -> { constraints :: List String
|
||||
joinConstraints :: Type -> { constraints :: List Identifier
|
||||
, ty :: Type }
|
||||
joinConstraints = go Nil
|
||||
where
|
||||
|
@ -5,10 +5,12 @@ import Prelude
|
||||
import Docs.Search.Extra ((>#>))
|
||||
import Docs.Search.Terminal (cyan)
|
||||
import Docs.Search.TypeDecoder (Constraint(..), FunDep(..), FunDeps(..), Kind(..), QualifiedName(..), Type(..), TypeArgument(..), joinForAlls, joinRows)
|
||||
import Docs.Search.Types (Identifier(..))
|
||||
|
||||
import Data.Maybe (Maybe(..), fromMaybe)
|
||||
import Data.Array as Array
|
||||
import Data.List as List
|
||||
import Data.Maybe (Maybe(..), fromMaybe)
|
||||
import Data.Newtype (unwrap)
|
||||
|
||||
|
||||
-- | A pretty-printer for types, for TTY with colors.
|
||||
@ -22,13 +24,13 @@ showType = case _ of
|
||||
|
||||
TypeApp (TypeApp (TypeConstructor
|
||||
(QualifiedName { moduleNameParts: [ "Prim" ]
|
||||
, name: "Function" }))
|
||||
, name: Identifier "Function" }))
|
||||
t1)
|
||||
t2 ->
|
||||
showType t1 <> syntax " -> " <> showType t2
|
||||
|
||||
TypeApp (TypeConstructor (QualifiedName { moduleNameParts: [ "Prim" ]
|
||||
, name: "Record" }))
|
||||
, name: Identifier "Record" }))
|
||||
row ->
|
||||
showRow false row
|
||||
|
||||
@ -89,7 +91,7 @@ showQualifiedName
|
||||
:: QualifiedName
|
||||
-> String
|
||||
showQualifiedName (QualifiedName { name })
|
||||
= name
|
||||
= unwrap name
|
||||
|
||||
|
||||
showRow
|
||||
@ -107,7 +109,7 @@ showRow asRow =
|
||||
opening <>
|
||||
( Array.intercalate ", " $ Array.fromFoldable $ rows <#>
|
||||
\entry ->
|
||||
entry.row <> syntax " :: " <> showType entry.ty
|
||||
unwrap entry.row <> syntax " :: " <> showType entry.ty
|
||||
) <>
|
||||
|
||||
(ty >#> \ty' -> " | " <> showType ty') <>
|
||||
|
@ -13,6 +13,7 @@ where
|
||||
import Docs.Search.Config (config)
|
||||
import Docs.Search.Extra (foldl1, foldr1)
|
||||
import Docs.Search.TypeDecoder (QualifiedName(..), Type(..), joinConstraints, joinRows)
|
||||
import Docs.Search.Types (Identifier(..))
|
||||
|
||||
import Prelude
|
||||
|
||||
@ -41,13 +42,13 @@ import Text.Parsing.StringParser.Combinators (fix, sepBy, sepBy1, sepEndBy, sepE
|
||||
-- | We need type queries because we don't have a full-featured type parser
|
||||
-- | available.
|
||||
data TypeQuery
|
||||
= QVar String
|
||||
| QConst String
|
||||
= QVar Identifier
|
||||
| QConst Identifier
|
||||
| QFun TypeQuery TypeQuery
|
||||
| QApp TypeQuery TypeQuery
|
||||
| QForAll (NonEmptyList String) TypeQuery
|
||||
| QConstraint String (List TypeQuery) TypeQuery
|
||||
| QRow (List (Tuple String TypeQuery))
|
||||
| QForAll (NonEmptyList Identifier) TypeQuery
|
||||
| QConstraint Identifier (List TypeQuery) TypeQuery
|
||||
| QRow (List (Tuple Identifier TypeQuery))
|
||||
|
||||
derive instance eqTypeQuery :: Eq TypeQuery
|
||||
derive instance genericTypeQuery :: Generic TypeQuery _
|
||||
@ -69,7 +70,8 @@ typeQueryParser = fix \typeQuery ->
|
||||
|
||||
row = string "(" *> rowFields <* string ")"
|
||||
|
||||
record = QApp (QConst "Record") <$> (string "{" *> rowFields <* string "}")
|
||||
record = QApp (QConst $ Identifier "Record") <$>
|
||||
(string "{" *> rowFields <* string "}")
|
||||
|
||||
binders =
|
||||
string "forall" *> some space *> sepEndBy1 ident skipSpaces <* string "." <* skipSpaces
|
||||
@ -111,32 +113,32 @@ concrete :: Parser TypeQuery
|
||||
concrete =
|
||||
QConst <$> upperCaseIdent
|
||||
|
||||
ident :: Parser String
|
||||
ident :: Parser Identifier
|
||||
ident = do
|
||||
head <- anyLetter
|
||||
rest <- Array.many (alphaNum <|> char '\'')
|
||||
pure $ fromCharArray $ pure head <> rest
|
||||
pure $ Identifier <$> fromCharArray $ pure head <> rest
|
||||
|
||||
upperCaseIdent :: Parser String
|
||||
upperCaseIdent :: Parser Identifier
|
||||
upperCaseIdent = do
|
||||
head <- upperCaseChar
|
||||
rest <- Array.many (alphaNum <|> char '\'')
|
||||
pure $ fromCharArray $ pure head <> rest
|
||||
pure $ Identifier $ fromCharArray $ pure head <> rest
|
||||
|
||||
lowerCaseIdent :: Parser String
|
||||
lowerCaseIdent :: Parser Identifier
|
||||
lowerCaseIdent = do
|
||||
head <- lowerCaseChar
|
||||
rest <- Array.many (alphaNum <|> char '\'')
|
||||
pure $ fromCharArray $ pure head <> rest
|
||||
pure $ Identifier $ fromCharArray $ pure head <> rest
|
||||
|
||||
space :: Parser Char
|
||||
space = char ' '
|
||||
|
||||
|
||||
-- | Used only in `getFreeVariables`.
|
||||
data FreeVarCounterQueueEntry = Unbind (Set.Set String) | Next TypeQuery
|
||||
data FreeVarCounterQueueEntry = Unbind (Set.Set Identifier) | Next TypeQuery
|
||||
|
||||
getFreeVariables :: TypeQuery -> Set.Set String
|
||||
getFreeVariables :: TypeQuery -> Set.Set Identifier
|
||||
getFreeVariables query = go Set.empty Set.empty (List.singleton $ Next query)
|
||||
where
|
||||
insertIfUnbound bound var free =
|
||||
@ -172,11 +174,11 @@ getFreeVariables query = go Set.empty Set.empty (List.singleton $ Next query)
|
||||
|
||||
|
||||
data Substitution
|
||||
= Instantiate String Type
|
||||
| Match String String
|
||||
| Generalize TypeQuery String
|
||||
| Substitute String String
|
||||
| MatchConstraints (Set String) (Set String)
|
||||
= Instantiate Identifier Type
|
||||
| Match Identifier Identifier
|
||||
| Generalize TypeQuery Identifier
|
||||
| Substitute Identifier Identifier
|
||||
| MatchConstraints (Set Identifier) (Set Identifier)
|
||||
| MissingConstraint
|
||||
| ExcessiveConstraint
|
||||
| RowsMismatch Int Int
|
||||
@ -225,9 +227,9 @@ unify query type_ = go Nil (List.singleton { q: query, t: type_ })
|
||||
|
||||
-- * Type variables
|
||||
go acc ({ q: QVar q, t: TypeVar v } : rest) =
|
||||
go (Substitute q v : acc) rest
|
||||
go (Substitute q (Identifier v) : acc) rest
|
||||
go acc ({ q, t: TypeVar v } : rest ) =
|
||||
go (Generalize q v : acc) rest
|
||||
go (Generalize q (Identifier v) : acc) rest
|
||||
go acc ({ q: QVar v, t } : rest) =
|
||||
go (Instantiate v t : acc) rest
|
||||
|
||||
@ -249,16 +251,16 @@ unify query type_ = go Nil (List.singleton { q: query, t: type_ })
|
||||
go acc ({ q: QFun q1 q2
|
||||
, t: TypeApp (TypeApp (TypeConstructor
|
||||
(QualifiedName { moduleNameParts: [ "Prim" ]
|
||||
, name: "Function" })) t1) t2 } : rest) =
|
||||
, name: Identifier "Function" })) t1) t2 } : rest) =
|
||||
go acc ({ q: q1, t: t1 } : { q: q2, t: t2 } : rest)
|
||||
go acc ({ q: q@(QFun q1 q2), t } : rest) =
|
||||
go (Mismatch q t : acc) rest
|
||||
|
||||
-- * Rows
|
||||
go acc ({ q: QApp (QConst "Record") (QRow qRows)
|
||||
go acc ({ q: QApp (QConst (Identifier "Record")) (QRow qRows)
|
||||
, t: TypeApp (TypeConstructor
|
||||
(QualifiedName { moduleNameParts: [ "Prim" ]
|
||||
, name: "Record" })) row } : rest) =
|
||||
, name: Identifier "Record" })) row } : rest) =
|
||||
let { rows, ty } = joinRows row
|
||||
qRowsLength = List.length qRows
|
||||
rowsLength = List.length rows in
|
||||
@ -319,8 +321,11 @@ typeVarPenalty substs =
|
||||
insertion v1 v2 = Map.insertWith append v1 (Set.singleton v2)
|
||||
|
||||
varSubstMapWith
|
||||
:: (String -> String -> Map String (Set String) -> Map String (Set String))
|
||||
-> Map String (Set String)
|
||||
:: (Identifier ->
|
||||
Identifier ->
|
||||
Map Identifier (Set Identifier) ->
|
||||
Map Identifier (Set Identifier))
|
||||
-> Map Identifier (Set Identifier)
|
||||
varSubstMapWith f =
|
||||
List.foldr (case _ of
|
||||
Substitute v1 v2 ->
|
||||
@ -363,7 +368,7 @@ mismatchPenalty = go 0
|
||||
|
||||
|
||||
-- | Only returns a list of type class names (lists of arguments are omitted).
|
||||
joinQueryConstraints :: TypeQuery -> { constraints :: List String
|
||||
joinQueryConstraints :: TypeQuery -> { constraints :: List Identifier
|
||||
, ty :: TypeQuery }
|
||||
joinQueryConstraints = go Nil
|
||||
where
|
||||
@ -408,7 +413,7 @@ typeSize = go 0 <<< List.singleton
|
||||
go (n + 1) rest
|
||||
go n (TypeApp (TypeApp (TypeConstructor
|
||||
(QualifiedName { moduleNameParts: [ "Prim" ]
|
||||
, name: "Function" })) t1) t2 : rest) =
|
||||
, name: Identifier "Function" })) t1) t2 : rest) =
|
||||
go (n + 1) (t1 : t2 : rest)
|
||||
go n (TypeApp q1 q2 : rest) =
|
||||
go (n + 1) (q1 : q2 : rest)
|
||||
|
@ -5,6 +5,7 @@ module Docs.Search.TypeShape where
|
||||
|
||||
import Docs.Search.TypeDecoder (QualifiedName(..), Type(..), joinForAlls, joinRows)
|
||||
import Docs.Search.TypeQuery (TypeQuery(..), getFreeVariables)
|
||||
import Docs.Search.Types (Identifier(..))
|
||||
|
||||
import Prelude
|
||||
|
||||
@ -102,7 +103,7 @@ shapeOfType ty = List.reverse $ go (pure ty) Nil
|
||||
go rest (PVar : acc)
|
||||
|
||||
TypeApp (TypeApp (TypeConstructor (QualifiedName { moduleNameParts: ["Prim"]
|
||||
, name: "Function" })) t1) t2 ->
|
||||
, name: Identifier "Function" })) t1) t2 ->
|
||||
go (t1 : t2 : rest) (PFun : acc)
|
||||
|
||||
TypeConstructor (QualifiedName { name }) ->
|
||||
|
@ -11,6 +11,17 @@ import Data.Generic.Rep.Show (genericShow)
|
||||
import Data.Newtype (class Newtype)
|
||||
|
||||
|
||||
newtype Identifier = Identifier String
|
||||
|
||||
derive instance newtypeIdentifier :: Newtype Identifier _
|
||||
derive instance genericIdentifier :: Generic Identifier _
|
||||
derive newtype instance eqIdentifier :: Eq Identifier
|
||||
derive newtype instance ordIdentifier :: Ord Identifier
|
||||
derive newtype instance showIdentifier :: Show Identifier
|
||||
derive newtype instance decodeJsonIdentifier :: DecodeJson Identifier
|
||||
derive newtype instance encodeJsonIdentifier :: EncodeJson Identifier
|
||||
|
||||
|
||||
newtype ModuleName = ModuleName String
|
||||
|
||||
derive instance newtypeModuleName :: Newtype ModuleName _
|
||||
@ -52,8 +63,14 @@ instance decodeJsonPackageInfo :: DecodeJson PackageInfo where
|
||||
instance encodeJsonPackageInfo :: EncodeJson PackageInfo where
|
||||
encodeJson = genericEncodeJson
|
||||
|
||||
packageInfoToString :: PackageInfo -> String
|
||||
packageInfoToString (Package (PackageName p)) = p
|
||||
packageInfoToString Builtin = "<builtin>"
|
||||
packageInfoToString LocalPackage = "<local package>"
|
||||
packageInfoToString UnknownPackage = "<unknown package>"
|
||||
newtype PackageScore = PackageScore Int
|
||||
|
||||
derive instance newtypePackageScore :: Newtype PackageScore _
|
||||
derive instance genericPackageScore :: Generic PackageScore _
|
||||
derive newtype instance eqPackageScore :: Eq PackageScore
|
||||
derive newtype instance ordPackageScore :: Ord PackageScore
|
||||
derive newtype instance semiringPackageScore :: Semiring PackageScore
|
||||
derive newtype instance ringPackageScore :: Ring PackageScore
|
||||
derive newtype instance showPackageScore :: Show PackageScore
|
||||
derive newtype instance decodeJsonPackageScore :: DecodeJson PackageScore
|
||||
derive newtype instance encodeJsonPackageScore :: EncodeJson PackageScore
|
||||
|
@ -3,6 +3,7 @@ module Test.Main where
|
||||
import Prelude
|
||||
|
||||
import Docs.Search.TypeDecoder (Constraint(..), FunDep(..), FunDeps(..), Kind(..), QualifiedName(..), Type(..))
|
||||
import Docs.Search.Types
|
||||
import Test.TypeQuery as TypeQuery
|
||||
import Test.IndexBuilder as IndexBuilder
|
||||
import Test.Declarations as Declarations
|
||||
@ -67,10 +68,7 @@ mainTest = do
|
||||
"""
|
||||
|
||||
assertRight (decodeJson qualifiedName)
|
||||
(QualifiedName { moduleNameParts: ["Prim"]
|
||||
, name: "Type"
|
||||
}
|
||||
)
|
||||
(qualified ["Prim"] "Type")
|
||||
|
||||
test "NamedKind" do
|
||||
let namedKind = mkJson """
|
||||
@ -87,10 +85,7 @@ mainTest = do
|
||||
"""
|
||||
|
||||
assertRight (decodeJson namedKind)
|
||||
(NamedKind $ QualifiedName { moduleNameParts: ["Prim"]
|
||||
, name: "Type"
|
||||
}
|
||||
)
|
||||
(NamedKind $ qualified ["Prim"] "Type")
|
||||
|
||||
test "Row" do
|
||||
let row = mkJson """
|
||||
@ -110,11 +105,7 @@ mainTest = do
|
||||
}
|
||||
"""
|
||||
|
||||
assertRight (decodeJson row)
|
||||
(Row $ NamedKind $ QualifiedName { moduleNameParts: ["Prim"]
|
||||
, name: "Type"
|
||||
}
|
||||
)
|
||||
assertRight (decodeJson row) (Row $ NamedKind $ qualified ["Prim"] "Type")
|
||||
|
||||
test "FunKind" do
|
||||
let funKind = mkJson """
|
||||
@ -154,14 +145,8 @@ mainTest = do
|
||||
}
|
||||
"""
|
||||
assertRight (decodeJson funKind)
|
||||
(FunKind (Row $ NamedKind $ QualifiedName { moduleNameParts: ["Prim"]
|
||||
, name: "Type"
|
||||
}
|
||||
)
|
||||
(Row $ NamedKind $ QualifiedName { moduleNameParts: ["Prim"]
|
||||
, name: "Type"
|
||||
}
|
||||
)
|
||||
(FunKind (Row $ NamedKind $ qualified ["Prim"] "Type")
|
||||
(Row $ NamedKind $ qualified ["Prim"] "Type")
|
||||
)
|
||||
|
||||
|
||||
@ -181,9 +166,7 @@ mainTest = do
|
||||
}
|
||||
"""
|
||||
assertRight (decodeJson constraint)
|
||||
(Constraint { constraintClass: QualifiedName { moduleNameParts: ["Prim"]
|
||||
, name: "Partial"
|
||||
}
|
||||
(Constraint { constraintClass: qualified ["Prim"] "Partial"
|
||||
, constraintArgs: []
|
||||
})
|
||||
|
||||
@ -230,14 +213,12 @@ mainTest = do
|
||||
|
||||
assertRight (decodeJson typeApp1) $
|
||||
TypeApp
|
||||
(TypeConstructor (QualifiedName { moduleNameParts:
|
||||
[ "Control"
|
||||
, "Monad"
|
||||
, "ST"
|
||||
, "Internal"
|
||||
],
|
||||
name: "ST"
|
||||
}
|
||||
(TypeConstructor (qualified [ "Control"
|
||||
, "Monad"
|
||||
, "ST"
|
||||
, "Internal"
|
||||
]
|
||||
"ST"
|
||||
))
|
||||
(TypeVar "h")
|
||||
|
||||
@ -256,9 +237,7 @@ mainTest = do
|
||||
}
|
||||
"""
|
||||
assertRight (decodeJson typeOp) $
|
||||
TypeOp $ QualifiedName { moduleNameParts: [ "Data", "NaturalTransformation" ]
|
||||
, name: "~>"
|
||||
}
|
||||
TypeOp $ qualified [ "Data", "NaturalTransformation" ] "~>"
|
||||
|
||||
test "BinaryNoParens" do
|
||||
let binaryNoParens = mkJson """
|
||||
@ -293,7 +272,7 @@ mainTest = do
|
||||
|
||||
assertRight (decodeJson binaryNoParens) $
|
||||
BinaryNoParensType
|
||||
(TypeOp $ QualifiedName { moduleNameParts: ["Data", "NaturalTransformation"], name: "~>" })
|
||||
(TypeOp $ qualified ["Data", "NaturalTransformation"] "~>")
|
||||
(TypeVar "m")
|
||||
(TypeVar "n")
|
||||
|
||||
@ -335,19 +314,8 @@ mainTest = do
|
||||
assertRight (decodeJson parensInType) $
|
||||
ParensInType $
|
||||
TypeApp
|
||||
(TypeConstructor (QualifiedName { moduleNameParts:
|
||||
[ "Data"
|
||||
, "Maybe"
|
||||
],
|
||||
name: "Maybe"
|
||||
}
|
||||
))
|
||||
(TypeConstructor (QualifiedName { moduleNameParts:
|
||||
[ "Prim"
|
||||
],
|
||||
name: "String"
|
||||
}
|
||||
))
|
||||
(TypeConstructor (qualified [ "Data", "Maybe" ] "Maybe"))
|
||||
(TypeConstructor (qualified [ "Prim" ] "String"))
|
||||
test "RCons" do
|
||||
|
||||
let rcons = mkJson """
|
||||
@ -388,8 +356,8 @@ mainTest = do
|
||||
|
||||
assertRight (decodeJson rcons) $
|
||||
RCons
|
||||
"tail"
|
||||
(TypeApp (TypeConstructor $ QualifiedName { moduleNameParts: [ "Data", "Symbol" ], name: "SProxy" })
|
||||
(Identifier "tail")
|
||||
(TypeApp (TypeConstructor $ qualified [ "Data", "Symbol" ] "SProxy")
|
||||
(TypeVar "t"))
|
||||
REmpty
|
||||
|
||||
@ -545,8 +513,8 @@ mainTest = do
|
||||
"""
|
||||
assertRight (decodeJson forallJson) $
|
||||
ForAll "f"
|
||||
(Just (FunKind (NamedKind (QualifiedName { moduleNameParts: ["Prim","RowList"], name: "RowList" })) (NamedKind (QualifiedName { moduleNameParts: ["Prim"], name: "Type" }))))
|
||||
(TypeApp (TypeApp (TypeConstructor (QualifiedName { moduleNameParts: ["Prim"], name: "Function" })) (TypeApp (TypeVar "f") (TypeVar "l"))) (TypeApp (TypeConstructor (QualifiedName { moduleNameParts: ["Data","List","Types"], name: "List" })) (ParensInType (TypeApp (TypeApp (TypeConstructor (QualifiedName { moduleNameParts: ["Data","Tuple"], name: "Tuple" })) (TypeConstructor (QualifiedName { moduleNameParts: ["Prim"], name: "String" }))) (TypeConstructor (QualifiedName { moduleNameParts: ["Prim"], name: "String" }))))))
|
||||
(Just (FunKind (NamedKind (QualifiedName { moduleNameParts: ["Prim","RowList"], name: Identifier "RowList" })) (NamedKind (QualifiedName { moduleNameParts: ["Prim"], name: Identifier "Type" }))))
|
||||
(TypeApp (TypeApp (TypeConstructor (QualifiedName { moduleNameParts: ["Prim"], name: Identifier "Function" })) (TypeApp (TypeVar "f") (TypeVar "l"))) (TypeApp (TypeConstructor (QualifiedName { moduleNameParts: ["Data","List","Types"], name: Identifier "List" })) (ParensInType (TypeApp (TypeApp (TypeConstructor (QualifiedName { moduleNameParts: ["Data","Tuple"], name: Identifier "Tuple" })) (TypeConstructor (QualifiedName { moduleNameParts: ["Prim"], name: Identifier "String" }))) (TypeConstructor (QualifiedName { moduleNameParts: ["Prim"], name: Identifier "String" }))))))
|
||||
|
||||
|
||||
|
||||
@ -558,7 +526,7 @@ mainTest = do
|
||||
{"annotation":[],"tag":"ForAll","contents":["o",{"annotation":[],"tag":"ForAll","contents":["r",{"annotation":[],"tag":"ForAll","contents":["l",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Type","Data","Boolean"],"And"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"l"},{"annotation":[],"tag":"TypeVar","contents":"r"},{"annotation":[],"tag":"TypeVar","contents":"o"}],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"BProxy"]},{"annotation":[],"tag":"TypeVar","contents":"l"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"BProxy"]},{"annotation":[],"tag":"TypeVar","contents":"r"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"BProxy"]},{"annotation":[],"tag":"TypeVar","contents":"o"}]}]}]}]},null]},null]},null]}
|
||||
"""
|
||||
|
||||
assertRight (decodeJson json) $ (ForAll "o" Nothing (ForAll "r" Nothing (ForAll "l" Nothing (ConstrainedType (Constraint { constraintArgs: [(TypeVar "l"),(TypeVar "r"),(TypeVar "o")], constraintClass: (QualifiedName { moduleNameParts: ["Type","Data","Boolean"], name: "And" }) }) (TypeApp (TypeApp (TypeConstructor (QualifiedName { moduleNameParts: ["Prim"], name: "Function" })) (TypeApp (TypeConstructor (QualifiedName { moduleNameParts: ["Type","Data","Boolean"], name: "BProxy" })) (TypeVar "l"))) (TypeApp (TypeApp (TypeConstructor (QualifiedName { moduleNameParts: ["Prim"], name: "Function" })) (TypeApp (TypeConstructor (QualifiedName { moduleNameParts: ["Type","Data","Boolean"], name: "BProxy" })) (TypeVar "r"))) (TypeApp (TypeConstructor (QualifiedName { moduleNameParts: ["Type","Data","Boolean"], name: "BProxy" })) (TypeVar "o"))))))))
|
||||
assertRight (decodeJson json) $ (ForAll "o" Nothing (ForAll "r" Nothing (ForAll "l" Nothing (ConstrainedType (Constraint { constraintArgs: [(TypeVar "l"),(TypeVar "r"),(TypeVar "o")], constraintClass: (QualifiedName { moduleNameParts: ["Type","Data","Boolean"], name: Identifier "And" }) }) (TypeApp (TypeApp (TypeConstructor (QualifiedName { moduleNameParts: ["Prim"], name: Identifier "Function" })) (TypeApp (TypeConstructor (QualifiedName { moduleNameParts: ["Type","Data","Boolean"], name: Identifier "BProxy" })) (TypeVar "l"))) (TypeApp (TypeApp (TypeConstructor (QualifiedName { moduleNameParts: ["Prim"], name: Identifier "Function" })) (TypeApp (TypeConstructor (QualifiedName { moduleNameParts: ["Type","Data","Boolean"], name: Identifier "BProxy" })) (TypeVar "r"))) (TypeApp (TypeConstructor (QualifiedName { moduleNameParts: ["Type","Data","Boolean"], name: Identifier "BProxy" })) (TypeVar "o"))))))))
|
||||
|
||||
suite "Kind encoder" do
|
||||
test "FunKind" do
|
||||
@ -570,4 +538,4 @@ mainTest = do
|
||||
|
||||
|
||||
qualified :: Array String -> String -> QualifiedName
|
||||
qualified moduleNameParts name = QualifiedName { moduleNameParts, name }
|
||||
qualified moduleNameParts name = QualifiedName { moduleNameParts, name: Identifier name }
|
||||
|
@ -3,6 +3,7 @@ module Test.TypeQuery where
|
||||
import Docs.Search.TypeDecoder (Constraint(..), QualifiedName(..), Type(..))
|
||||
import Docs.Search.TypeQuery (Substitution(..), TypeQuery(..), getFreeVariables, parseTypeQuery, penalty, typeVarPenalty)
|
||||
import Docs.Search.TypeShape (ShapeChunk(..), shapeOfType, shapeOfTypeQuery)
|
||||
import Docs.Search.Types (Identifier(..))
|
||||
|
||||
import Prelude
|
||||
|
||||
@ -25,193 +26,195 @@ tests = do
|
||||
|
||||
test "test #0" do
|
||||
let input = "a"
|
||||
assertRight (parseTypeQuery input) (QVar "a")
|
||||
assertRight (parseTypeQuery input) (qVar "a")
|
||||
|
||||
test "test #1" do
|
||||
let input = "ab"
|
||||
assertRight (parseTypeQuery input) (QVar "ab")
|
||||
assertRight (parseTypeQuery input) (qVar "ab")
|
||||
|
||||
test "test #2" do
|
||||
let input = "a b"
|
||||
assertRight (parseTypeQuery input) (QApp (QVar "a") (QVar "b"))
|
||||
assertRight (parseTypeQuery input) (QApp (qVar "a") (qVar "b"))
|
||||
|
||||
test "test #3" do
|
||||
let input = "a b c"
|
||||
assertRight (parseTypeQuery input) (QApp (QApp (QVar "a") (QVar "b")) (QVar "c"))
|
||||
assertRight (parseTypeQuery input) (QApp (QApp (qVar "a") (qVar "b")) (qVar "c"))
|
||||
|
||||
test "test #4" do
|
||||
let input = "a -> b"
|
||||
assertRight (parseTypeQuery input) (QFun (QVar "a") (QVar "b"))
|
||||
assertRight (parseTypeQuery input) (QFun (qVar "a") (qVar "b"))
|
||||
|
||||
test "test #5" do
|
||||
let input = "a -> b c"
|
||||
assertRight (parseTypeQuery input) (QFun (QVar "a") (QApp (QVar "b") (QVar "c")))
|
||||
assertRight (parseTypeQuery input) (QFun (qVar "a") (QApp (qVar "b") (qVar "c")))
|
||||
|
||||
test "test #6" do
|
||||
let input = "a b -> c"
|
||||
assertRight (parseTypeQuery input) (QFun (QApp (QVar "a") (QVar "b")) (QVar "c"))
|
||||
assertRight (parseTypeQuery input) (QFun (QApp (qVar "a") (qVar "b")) (qVar "c"))
|
||||
|
||||
test "test #7" do
|
||||
let input = "a b"
|
||||
assertRight (parseTypeQuery input) (QApp (QVar "a") (QVar "b"))
|
||||
assertRight (parseTypeQuery input) (QApp (qVar "a") (qVar "b"))
|
||||
|
||||
test "test #8" do
|
||||
let input = "a (b c)"
|
||||
assertRight (parseTypeQuery input) (QApp (QVar "a") (QApp (QVar "b") (QVar "c")))
|
||||
assertRight (parseTypeQuery input) (QApp (qVar "a") (QApp (qVar "b") (qVar "c")))
|
||||
|
||||
test "test #9" do
|
||||
let input = "(a b) (c d)"
|
||||
assertRight (parseTypeQuery input)
|
||||
(QApp (QApp (QVar "a") (QVar "b"))
|
||||
(QApp (QVar "c") (QVar "d")))
|
||||
(QApp (QApp (qVar "a") (qVar "b"))
|
||||
(QApp (qVar "c") (qVar "d")))
|
||||
|
||||
test "test #10" do
|
||||
let input = "a ( b c )"
|
||||
assertRight (parseTypeQuery input) (QApp (QVar "a") (QApp (QVar "b") (QVar "c")))
|
||||
assertRight (parseTypeQuery input) (QApp (qVar "a") (QApp (qVar "b") (qVar "c")))
|
||||
|
||||
test "test #11" do
|
||||
let input = "aaa"
|
||||
assertRight (parseTypeQuery input) (QVar "aaa")
|
||||
assertRight (parseTypeQuery input) (qVar "aaa")
|
||||
|
||||
test "test #12" do
|
||||
let input = "aaa ( bbb ccc )"
|
||||
assertRight (parseTypeQuery input) (QApp (QVar "aaa") (QApp (QVar "bbb") (QVar "ccc")))
|
||||
assertRight (parseTypeQuery input) (QApp (qVar "aaa") (QApp (qVar "bbb") (qVar "ccc")))
|
||||
|
||||
test "test #13" do
|
||||
let input = "(a -> b) -> (c -> d)"
|
||||
assertRight (parseTypeQuery input) (QFun (QFun (QVar "a") (QVar "b"))
|
||||
(QFun (QVar "c") (QVar "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"))))
|
||||
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")))
|
||||
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"))
|
||||
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")))
|
||||
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 [QVar "m"])
|
||||
(QFun (QVar "a")
|
||||
(QApp (QVar "m") (QVar "a")))))
|
||||
(qConstraint "Monad" (l [qVar "m"])
|
||||
(QFun (qVar "a")
|
||||
(QApp (qVar "m") (qVar "a")))))
|
||||
|
||||
test "test #19" do
|
||||
let input = "{ a :: Int }"
|
||||
assertRight (parseTypeQuery input)
|
||||
(QApp (QConst "Record") (QRow (pure (Tuple "a" (QConst "Int")))))
|
||||
(QApp (qConst "Record") (QRow (pure (Tuple (Identifier "a") (qConst "Int")))))
|
||||
|
||||
test "test #20" do
|
||||
let input = "{a::Int}"
|
||||
assertRight (parseTypeQuery input)
|
||||
(QApp (QConst "Record") (QRow (pure (Tuple "a" (QConst "Int")))))
|
||||
(QApp (qConst "Record") (QRow (pure (Tuple (Identifier "a") (qConst "Int")))))
|
||||
|
||||
test "test #21" do
|
||||
let input = "Int"
|
||||
assertRight (parseTypeQuery input) (QConst "Int")
|
||||
assertRight (parseTypeQuery input) (qConst "Int")
|
||||
|
||||
test "test #22" do
|
||||
let input = "a->b"
|
||||
assertRight (parseTypeQuery input) (QFun (QVar "a") (QVar "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" (l [QVar "m"])
|
||||
(QFun (QApp (QApp (QConst "Process")
|
||||
(QVar "m")) (QVar "a"))
|
||||
(QApp (QVar "m") (QVar "a")))))
|
||||
(qConstraint "MonadRec" (l [qVar "m"])
|
||||
(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 [QVar "t"])
|
||||
(QConstraint "Apply" (l [QVar "f"]) (QVar "f"))))
|
||||
(qConstraint "Foldable1" (l [qVar "t"])
|
||||
(qConstraint "Apply" (l [qVar "f"]) (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" (l [QVar "m"])
|
||||
(QFun (QApp (QApp (QConst "Process")
|
||||
(QVar "m")) (QVar "a"))
|
||||
(QApp (QVar "m") (QVar "a"))))))
|
||||
(qConstraint "MonadRec" (l [qVar "m"])
|
||||
(QFun (QApp (QApp (qConst "Process")
|
||||
(qVar "m")) (qVar "a"))
|
||||
(QApp (qVar "m") (qVar "a"))))))
|
||||
|
||||
test "test #26" do
|
||||
let input = "m a -> (a -> m b) -> m b"
|
||||
assertRight (parseTypeQuery input) (QFun (QApp (QVar "m") (QVar "a")) (QFun (QFun (QVar "a") (QApp (QVar "m") (QVar "b"))) (QApp (QVar "m") (QVar "b"))))
|
||||
assertRight (parseTypeQuery input) (QFun (QApp (qVar "m") (qVar "a")) (QFun (QFun (qVar "a") (QApp (qVar "m") (qVar "b"))) (QApp (qVar "m") (qVar "b"))))
|
||||
|
||||
test "test #27" do
|
||||
let input = "forall f a. Alternative f => Lazy (f (List a)) => f a -> f (List a)"
|
||||
assertRight (parseTypeQuery input) ((QForAll (nl "f" ["a"]))
|
||||
(QConstraint "Alternative" (l [QVar "f"])
|
||||
(QConstraint "Lazy" (l [QApp (QVar "f")
|
||||
(QApp (QConst "List") (QVar "a"))])
|
||||
(QFun (QApp (QVar "f") (QVar "a"))
|
||||
(QApp (QVar "f")
|
||||
(QApp (QConst "List") (QVar "a")))))))
|
||||
(qConstraint "Alternative" (l [qVar "f"])
|
||||
(qConstraint "Lazy" (l [QApp (qVar "f")
|
||||
(QApp (qConst "List") (qVar "a"))])
|
||||
(QFun (QApp (qVar "f") (qVar "a"))
|
||||
(QApp (qVar "f")
|
||||
(QApp (qConst "List") (qVar "a")))))))
|
||||
|
||||
test "test #28" do
|
||||
let input = "forall f a. Alternative f => Lazy(f (List a))=>f a -> f (List a)"
|
||||
assertRight (parseTypeQuery input) ((QForAll (nl "f" ["a"]))
|
||||
(QConstraint "Alternative" (l [QVar "f"])
|
||||
(QConstraint "Lazy" (l [QApp (QVar "f")
|
||||
(QApp (QConst "List") (QVar "a"))])
|
||||
(QFun (QApp (QVar "f") (QVar "a"))
|
||||
(QApp (QVar "f")
|
||||
(QApp (QConst "List") (QVar "a")))))))
|
||||
(qConstraint "Alternative" (l [qVar "f"])
|
||||
(qConstraint "Lazy" (l [QApp (qVar "f")
|
||||
(QApp (qConst "List") (qVar "a"))])
|
||||
(QFun (QApp (qVar "f") (qVar "a"))
|
||||
(QApp (qVar "f")
|
||||
(QApp (qConst "List") (qVar "a")))))))
|
||||
|
||||
test "test #29" do
|
||||
let input = "{a::Int,b::Int}"
|
||||
assertRight (parseTypeQuery input)
|
||||
(QApp (QConst "Record") (QRow (List.fromFoldable [ Tuple "a" (QConst "Int"), Tuple "b" (QConst "Int")])))
|
||||
(QApp (qConst "Record") (QRow (List.fromFoldable
|
||||
[ Tuple (Identifier "a") (qConst "Int")
|
||||
, Tuple (Identifier "b") (qConst "Int")])))
|
||||
|
||||
test "test #30" do
|
||||
let input = "{record''' :: Int}"
|
||||
assertRight (parseTypeQuery input)
|
||||
(QApp (QConst "Record") (QRow (List.fromFoldable [ Tuple "record'''" (QConst "Int")])))
|
||||
(QApp (qConst "Record") (QRow (List.fromFoldable [ Tuple (Identifier "record'''") (qConst "Int")])))
|
||||
|
||||
test "test #31" do
|
||||
let input = "(row''' :: Int)"
|
||||
assertRight (parseTypeQuery input)
|
||||
(QRow (List.fromFoldable [ Tuple "row'''" (QConst "Int")]))
|
||||
(QRow (List.fromFoldable [ Tuple (Identifier "row'''") (qConst "Int")]))
|
||||
|
||||
test "test #32" do
|
||||
let input = "(row1 :: Int, row2 :: (),row3::(row4::{}))"
|
||||
assertRight (parseTypeQuery input)
|
||||
(QRow (l [ Tuple "row1" (QConst "Int")
|
||||
, Tuple "row2" (QRow Nil)
|
||||
, Tuple "row3" (QRow (l [ Tuple "row4" (QApp (QConst "Record") (QRow Nil)) ])) ]))
|
||||
(QRow (l [ Tuple (Identifier "row1") (qConst "Int")
|
||||
, Tuple (Identifier "row2") (QRow Nil)
|
||||
, Tuple (Identifier "row3") (QRow (l [ Tuple (Identifier "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")))))
|
||||
(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")))))
|
||||
(qConstraint "Foldable1" ((qVar "t") : Nil) (qConstraint "Apply" ((qVar "f") : Nil) (QFun (QApp (qVar "t") (QApp (qVar "f") (qVar "a"))) (QApp (qVar "f") (qVar "a")))))
|
||||
|
||||
test "test #35" do
|
||||
let input = "Generic a rep => GenericEq rep => a -> a -> Boolean"
|
||||
assertRight (parseTypeQuery input)
|
||||
(QConstraint "Generic" ((QVar "a") : (QVar "rep") : Nil)
|
||||
(QConstraint "GenericEq" ((QVar "rep") : Nil)
|
||||
(QFun (QVar "a") (QFun (QVar "a") (QConst "Boolean")))))
|
||||
(qConstraint "Generic" ((qVar "a") : (qVar "rep") : Nil)
|
||||
(qConstraint "GenericEq" ((qVar "rep") : Nil)
|
||||
(QFun (qVar "a") (QFun (qVar "a") (qConst "Boolean")))))
|
||||
|
||||
suite "polish notation" do
|
||||
|
||||
@ -246,7 +249,7 @@ tests = do
|
||||
|
||||
fun t1 t2 =
|
||||
TypeApp (TypeApp (TypeConstructor (QualifiedName { moduleNameParts: ["Prim"]
|
||||
, name: "Function" })) t1) t2
|
||||
, name: Identifier "Function" })) t1) t2
|
||||
type_ =
|
||||
ForAll "a" Nothing $
|
||||
ForAll "rep" Nothing $
|
||||
@ -314,70 +317,70 @@ tests = do
|
||||
Assert.equal 0 (typeVarPenalty mempty)
|
||||
|
||||
test "#1" do
|
||||
Assert.equal 0 (typeVarPenalty $ l [ Substitute "a" "b"
|
||||
, Substitute "b" "a"
|
||||
Assert.equal 0 (typeVarPenalty $ l [ substitute "a" "b"
|
||||
, substitute "b" "a"
|
||||
])
|
||||
|
||||
test "#2" do
|
||||
Assert.equal 0 (typeVarPenalty $ l [ Substitute "a" "b"
|
||||
, Substitute "a" "b"
|
||||
, Substitute "a" "b"
|
||||
Assert.equal 0 (typeVarPenalty $ l [ substitute "a" "b"
|
||||
, substitute "a" "b"
|
||||
, substitute "a" "b"
|
||||
])
|
||||
|
||||
test "#3" do
|
||||
Assert.equal 1 (typeVarPenalty $ l [ Substitute "a" "b"
|
||||
, Substitute "a" "c"
|
||||
Assert.equal 1 (typeVarPenalty $ l [ substitute "a" "b"
|
||||
, substitute "a" "c"
|
||||
])
|
||||
|
||||
test "#4" do
|
||||
Assert.equal 1 (typeVarPenalty $ l [ Substitute "a" "b"
|
||||
, Substitute "b" "a"
|
||||
, Substitute "b" "c"
|
||||
Assert.equal 1 (typeVarPenalty $ l [ substitute "a" "b"
|
||||
, substitute "b" "a"
|
||||
, substitute "b" "c"
|
||||
])
|
||||
|
||||
test "#5" do
|
||||
Assert.equal 0 (typeVarPenalty $ l [ Substitute "a" "b"
|
||||
, Substitute "b" "c"
|
||||
, Substitute "c" "a"
|
||||
Assert.equal 0 (typeVarPenalty $ l [ substitute "a" "b"
|
||||
, substitute "b" "c"
|
||||
, substitute "c" "a"
|
||||
])
|
||||
|
||||
test "#6" do
|
||||
Assert.equal 2 (typeVarPenalty $ l [ Substitute "a" "b"
|
||||
, Substitute "a" "c"
|
||||
, Substitute "a" "a"
|
||||
Assert.equal 2 (typeVarPenalty $ l [ substitute "a" "b"
|
||||
, substitute "a" "c"
|
||||
, substitute "a" "a"
|
||||
])
|
||||
|
||||
test "#7" do
|
||||
Assert.equal 2 (typeVarPenalty $ l [ Substitute "a" "a"
|
||||
, Substitute "b" "a"
|
||||
, Substitute "c" "a"
|
||||
Assert.equal 2 (typeVarPenalty $ l [ substitute "a" "a"
|
||||
, substitute "b" "a"
|
||||
, substitute "c" "a"
|
||||
])
|
||||
|
||||
test "#8" do
|
||||
Assert.equal 4 (typeVarPenalty $ l [ Substitute "a" "a"
|
||||
, Substitute "b" "a"
|
||||
, Substitute "c" "a"
|
||||
, Substitute "a" "b"
|
||||
, Substitute "a" "c"
|
||||
, Substitute "a" "a"
|
||||
Assert.equal 4 (typeVarPenalty $ l [ substitute "a" "a"
|
||||
, substitute "b" "a"
|
||||
, substitute "c" "a"
|
||||
, substitute "a" "b"
|
||||
, substitute "a" "c"
|
||||
, substitute "a" "a"
|
||||
])
|
||||
|
||||
test "#9" do
|
||||
Assert.equal 0 (typeVarPenalty $ l [ Substitute "a" "e"
|
||||
, Substitute "b" "d"
|
||||
, Substitute "c" "f"
|
||||
Assert.equal 0 (typeVarPenalty $ l [ substitute "a" "e"
|
||||
, substitute "b" "d"
|
||||
, substitute "c" "f"
|
||||
])
|
||||
|
||||
suite "unification" do
|
||||
test "instantiation #0" do
|
||||
let mVarQuery = QVar "m"
|
||||
unitConstQuery = QConst "Unit"
|
||||
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"
|
||||
let query = qVar "m"
|
||||
t1 = TypeVar "m"
|
||||
|
||||
Assert.assert "qeneralization #0" $
|
||||
@ -387,19 +390,37 @@ tests = do
|
||||
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
|
||||
nl
|
||||
:: forall t
|
||||
. Foldable t
|
||||
=> Functor t
|
||||
=> String
|
||||
-> t String
|
||||
-> NonEmptyList Identifier
|
||||
nl x rst = NonEmptyList.cons' (Identifier x) $ List.fromFoldable (rst <#> Identifier)
|
||||
|
||||
unitType :: Type
|
||||
unitType = TypeConstructor (QualifiedName { moduleNameParts: []
|
||||
, name: "Unit"
|
||||
, name: Identifier "Unit"
|
||||
})
|
||||
|
||||
countFreeVars :: TypeQuery -> Int
|
||||
countFreeVars = getFreeVariables >>> Set.size
|
||||
|
||||
qname :: Array String -> String -> QualifiedName
|
||||
qname m n = QualifiedName { moduleNameParts: m, name: n }
|
||||
qname m n = QualifiedName { moduleNameParts: m, name: Identifier n }
|
||||
|
||||
constr :: QualifiedName -> Array Type -> Constraint
|
||||
constr c a = Constraint { constraintClass: c, constraintArgs: a }
|
||||
|
||||
qVar :: String -> TypeQuery
|
||||
qVar = QVar <<< Identifier
|
||||
|
||||
qConst :: String -> TypeQuery
|
||||
qConst = QConst <<< Identifier
|
||||
|
||||
qConstraint :: String -> List TypeQuery -> TypeQuery -> TypeQuery
|
||||
qConstraint = QConstraint <<< Identifier
|
||||
|
||||
substitute :: String -> String -> Substitution
|
||||
substitute a b = Substitute (Identifier a) (Identifier b)
|
||||
|
Loading…
Reference in New Issue
Block a user