mirror of
https://github.com/rowtype-yoga/purescript-docs-search.git
synced 2024-09-11 12:35:37 +03:00
a bunch of improvements
This commit is contained in:
klntsky
parent
f354ade0f7
commit
62bd942bf0
@ -61,6 +61,9 @@ insertStyle doc = do
|
||||
.result {
|
||||
font-size: 1.25em;
|
||||
}
|
||||
.result__body .keyword, .result__body .syntax {
|
||||
color: #0B71B4;
|
||||
}
|
||||
"""
|
||||
mbHead <-
|
||||
ParentNode.querySelector (wrap "head") (Document.toParentNode doc)
|
||||
|
||||
@ -10,15 +10,19 @@ import Halogen.HTML as HH
|
||||
import Halogen.HTML.CSS as HS
|
||||
import Halogen.HTML.Events as HE
|
||||
import Halogen.HTML.Properties as HP
|
||||
import Web.UIEvent.KeyboardEvent as KeyboardEvent
|
||||
|
||||
type State = { input :: String }
|
||||
|
||||
data Action
|
||||
= InputAction String
|
||||
| EnterPressed
|
||||
| EscapePressed
|
||||
| FocusChanged Boolean
|
||||
|
||||
data Message
|
||||
= InputUpdated String
|
||||
| InputCleared
|
||||
| Focused
|
||||
| LostFocus
|
||||
|
||||
@ -37,7 +41,12 @@ handleAction :: forall m. Action -> H.HalogenM State Action () Message m Unit
|
||||
handleAction = case _ of
|
||||
InputAction input -> do
|
||||
H.modify_ $ const { input }
|
||||
H.raise $ InputUpdated input
|
||||
EnterPressed -> do
|
||||
state <- H.get
|
||||
H.raise $ InputUpdated state.input
|
||||
EscapePressed -> do
|
||||
H.modify_ (_ { input = "" })
|
||||
H.raise $ InputCleared
|
||||
FocusChanged status -> do
|
||||
H.raise
|
||||
if status
|
||||
@ -60,6 +69,11 @@ render state =
|
||||
[ HP.value state.input
|
||||
, HP.placeholder "Search for definitions"
|
||||
, HP.type_ HP.InputText
|
||||
, HE.onKeyUp (\event ->
|
||||
case KeyboardEvent.code event of
|
||||
"Enter" -> Just EnterPressed
|
||||
"Escape" -> Just EscapePressed
|
||||
_ -> Nothing)
|
||||
, HE.onValueInput (Just <<< InputAction)
|
||||
, HE.onFocusIn $ const $ Just $ FocusChanged true
|
||||
, HE.onFocusOut $ const $ Just $ FocusChanged false
|
||||
|
||||
@ -4,14 +4,15 @@ import Prelude
|
||||
|
||||
import Spago.Search.Index
|
||||
import Spago.Search.TypeDecoder
|
||||
import Spago.Search.TypeShape
|
||||
import Spago.Search.TypeQuery
|
||||
import Spago.Search.TypeShape
|
||||
|
||||
import CSS (textWhitespace, whitespacePreWrap)
|
||||
import Data.Array ((!!))
|
||||
import Data.Array as Array
|
||||
import Data.Either (Either(..))
|
||||
import Data.List as List
|
||||
import Data.Maybe (Maybe(..), isNothing, isJust)
|
||||
import Data.Maybe (Maybe(..), isJust, isNothing)
|
||||
import Data.Newtype (unwrap, wrap)
|
||||
import Data.Search.Trie as Trie
|
||||
import Data.String (length) as String
|
||||
@ -27,14 +28,16 @@ import Halogen.HTML.Events as HE
|
||||
import Halogen.HTML.Properties as HP
|
||||
import Spago.Search.App.SearchField (Message(..))
|
||||
import Spago.Search.DocsJson (loadDeclarations)
|
||||
import Spago.Search.Extra (whenJust)
|
||||
import Spago.Search.Extra (whenJust, (>#>))
|
||||
import Web.DOM.Element (Element)
|
||||
import Web.DOM.Element as Element
|
||||
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 Mode = Off | Loading | Active
|
||||
|
||||
-- | Is it a search by type or by name?
|
||||
data ResultsType = TypeResults TypeQuery | DeclResults
|
||||
|
||||
type State = { mbIndex :: Maybe SearchIndex
|
||||
@ -43,6 +46,7 @@ type State = { mbIndex :: Maybe SearchIndex
|
||||
, input :: String
|
||||
, contents :: Element
|
||||
, resultsCount :: Int
|
||||
, mode :: Mode
|
||||
}
|
||||
|
||||
data Query a
|
||||
@ -50,9 +54,12 @@ data Query a
|
||||
|
||||
data Action
|
||||
= SearchResultClicked String
|
||||
| ShowMore
|
||||
| MoreResultsRequested
|
||||
|
||||
mkComponent :: forall o i. Element -> H.Component HH.HTML Query i o Aff
|
||||
mkComponent
|
||||
:: forall o i
|
||||
. Element
|
||||
-> H.Component HH.HTML Query i o Aff
|
||||
mkComponent contents =
|
||||
H.mkComponent
|
||||
{ initialState: const { mbIndex: Nothing
|
||||
@ -61,46 +68,66 @@ mkComponent contents =
|
||||
, input: ""
|
||||
, contents
|
||||
, resultsCount: 25
|
||||
, mode: Off
|
||||
}
|
||||
, render
|
||||
, eval: H.mkEval $ H.defaultEval { handleQuery = handleQuery
|
||||
, handleAction = handleAction }
|
||||
}
|
||||
|
||||
handleQuery :: forall o a. Query a -> H.HalogenM State Action () o Aff (Maybe a)
|
||||
handleQuery
|
||||
:: forall o a
|
||||
. Query a
|
||||
-> H.HalogenM State Action () o Aff (Maybe a)
|
||||
handleQuery (SearchFieldMessage Focused next) = do
|
||||
state <- H.get
|
||||
when (isNothing state.mbIndex) do
|
||||
eiDeclarations <- H.liftAff $ loadDeclarations "../spago-search-index.js"
|
||||
pure Nothing
|
||||
handleQuery (SearchFieldMessage LostFocus next) = do
|
||||
pure Nothing
|
||||
handleQuery (SearchFieldMessage InputCleared next) = do
|
||||
H.modify_ (_ { results = [], input = "", mode = Off })
|
||||
showPageContents
|
||||
pure Nothing
|
||||
handleQuery (SearchFieldMessage (InputUpdated input) next) = do
|
||||
H.modify_ (_ { input = input })
|
||||
|
||||
H.get >>= \state -> when (isNothing state.mbIndex) do
|
||||
H.modify_ (_ { mode = Loading })
|
||||
eiDeclarations <-
|
||||
H.liftAff $ loadDeclarations "../spago-search-index.js"
|
||||
case eiDeclarations of
|
||||
Left err -> do
|
||||
H.liftEffect do
|
||||
error $ "spago-search: couldn't load search index: " <> err
|
||||
Right declarations -> do
|
||||
H.modify_ (_ { mbIndex = Just $ mkSearchIndex declarations })
|
||||
pure Nothing
|
||||
handleQuery (SearchFieldMessage LostFocus next) = do
|
||||
pure Nothing
|
||||
handleQuery (SearchFieldMessage (InputUpdated input) next) = do
|
||||
H.modify_ (_ { input = input })
|
||||
|
||||
H.modify_ (_ { mode = Active })
|
||||
|
||||
if String.length input < 2
|
||||
then do
|
||||
|
||||
showPageContents
|
||||
H.modify_ (_ { results = [] })
|
||||
|
||||
else do
|
||||
|
||||
hidePageContents
|
||||
state <- H.get
|
||||
|
||||
whenJust (unwrap <$> state.mbIndex) \index -> do
|
||||
let path = List.fromFoldable $
|
||||
String.toCharArray $
|
||||
String.toLower input
|
||||
|
||||
eiTypeQuery = parseTypeQuery input
|
||||
|
||||
resultsType =
|
||||
case eiTypeQuery of
|
||||
Left _ -> DeclResults
|
||||
Right query
|
||||
| isValuableQuery query -> TypeResults query
|
||||
| isValuableTypeQuery query -> TypeResults query
|
||||
| otherwise -> DeclResults
|
||||
|
||||
results =
|
||||
case resultsType of
|
||||
DeclResults ->
|
||||
@ -111,18 +138,24 @@ handleQuery (SearchFieldMessage (InputUpdated input) next) = do
|
||||
index.decls
|
||||
TypeResults query ->
|
||||
List.toUnfoldable $
|
||||
Trie.queryValues shape index.types >>= identity
|
||||
join $
|
||||
Trie.queryValues shape index.types
|
||||
where
|
||||
shape = shapeOfTypeQuery query
|
||||
|
||||
H.modify_ (_ { results = results
|
||||
, resultsType = resultsType
|
||||
, resultsCount = 25 })
|
||||
pure Nothing
|
||||
|
||||
handleAction :: forall o. Action -> H.HalogenM State Action () o Aff Unit
|
||||
handleAction
|
||||
:: forall o
|
||||
. Action
|
||||
-> H.HalogenM State Action () o Aff Unit
|
||||
handleAction = case _ of
|
||||
ShowMore -> do
|
||||
MoreResultsRequested -> do
|
||||
H.modify_ (\state -> state { resultsCount = state.resultsCount + 25 })
|
||||
|
||||
SearchResultClicked moduleName -> do
|
||||
-- Decide if we are going to load a new page or to jump to a hash on the
|
||||
-- current page. In the latter case, hide search results and show the main
|
||||
@ -138,23 +171,32 @@ handleAction = case _ of
|
||||
showPageContents
|
||||
H.modify_ (_ { input = "" })
|
||||
|
||||
showPageContents :: forall o. H.HalogenM State Action () o Aff Unit
|
||||
showPageContents
|
||||
:: forall o
|
||||
. H.HalogenM State Action () o Aff Unit
|
||||
showPageContents = do
|
||||
state <- H.get
|
||||
H.liftEffect do
|
||||
Element.removeAttribute "style" state.contents
|
||||
|
||||
hidePageContents :: forall o. H.HalogenM State Action () o Aff Unit
|
||||
hidePageContents
|
||||
:: forall o
|
||||
. H.HalogenM State Action () o Aff Unit
|
||||
hidePageContents = do
|
||||
state <- H.get
|
||||
H.liftEffect do
|
||||
Element.setAttribute "style" "display: none" state.contents
|
||||
|
||||
render :: forall m. State -> H.ComponentHTML Action () m
|
||||
render { mbIndex: Nothing } =
|
||||
HH.div_ []
|
||||
render { input: "" } =
|
||||
HH.div_ []
|
||||
render
|
||||
:: forall m
|
||||
. State
|
||||
-> H.ComponentHTML Action () m
|
||||
render { mbIndex: Nothing, mode: Loading } =
|
||||
HH.div [ HP.classes [ wrap "container", wrap "clearfix" ] ] $
|
||||
pure $
|
||||
HH.div [ HP.classes [ wrap "col", wrap "col--main" ] ] $
|
||||
[ HH.h1_ [ HH.text "Loading..." ] ]
|
||||
|
||||
render state =
|
||||
HH.div [ HP.classes [ wrap "container", wrap "clearfix" ] ] $
|
||||
pure $
|
||||
@ -188,20 +230,25 @@ render state =
|
||||
, HH.div [ HP.class_ (wrap "load_more"), HP.id_ "load-more" ]
|
||||
[ if Array.length selectedResults < Array.length state.results
|
||||
then HH.a [ HP.id_ "load-more-link"
|
||||
, HE.onClick $ const $ Just ShowMore ]
|
||||
, HE.onClick $ const $ Just MoreResultsRequested ]
|
||||
[ HH.text "Show more results" ]
|
||||
else HH.p_
|
||||
[ HH.text "No further results." ]
|
||||
]
|
||||
]
|
||||
|
||||
renderSummary :: forall a b. String -> HH.HTML b a
|
||||
renderSummary
|
||||
:: forall a b
|
||||
. String
|
||||
-> HH.HTML b a
|
||||
renderSummary text =
|
||||
HH.div [ HP.id_ "spago-search-summary" ]
|
||||
[ HH.text text
|
||||
]
|
||||
[ HH.text text ]
|
||||
|
||||
renderResult :: forall a. SearchResult -> Array (HH.HTML a Action)
|
||||
renderResult
|
||||
:: forall a
|
||||
. SearchResult
|
||||
-> Array (HH.HTML a Action)
|
||||
renderResult = unwrap >>> \result ->
|
||||
[ HH.div [ HP.class_ (wrap "result") ]
|
||||
[ HH.h3 [ HP.class_ (wrap "result__title") ]
|
||||
@ -218,22 +265,21 @@ renderResult = unwrap >>> \result ->
|
||||
, HH.div [ HP.class_ (wrap "result__body") ] $
|
||||
renderResultType result <>
|
||||
|
||||
case result.comments of
|
||||
Just comments -> [ HH.pre [ HS.style do
|
||||
textWhitespace whitespacePreWrap ]
|
||||
[ HH.text comments ]
|
||||
]
|
||||
Nothing -> [ ]
|
||||
result.comments >#>
|
||||
\comments -> [ HH.pre [ HS.style do
|
||||
textWhitespace whitespacePreWrap ]
|
||||
[ HH.text comments ]
|
||||
]
|
||||
|
||||
, HH.div [ HP.class_ (wrap "result__actions") ]
|
||||
|
||||
[ HH.span [ HP.class_ (wrap "result__actions__item") ]
|
||||
[ HH.span [ HP.classes [ wrap "badge"
|
||||
, wrap "badge--package"
|
||||
]
|
||||
, HP.title "Package"
|
||||
]
|
||||
[ HH.text "P"
|
||||
]
|
||||
[ HH.text "P" ]
|
||||
, HH.text result.packageName
|
||||
]
|
||||
|
||||
@ -243,8 +289,7 @@ renderResult = unwrap >>> \result ->
|
||||
]
|
||||
, HP.title "Module"
|
||||
]
|
||||
[ HH.text "M"
|
||||
]
|
||||
[ HH.text "M" ]
|
||||
, HH.text result.moduleName
|
||||
]
|
||||
]
|
||||
@ -254,42 +299,115 @@ renderResultType
|
||||
:: forall a rest
|
||||
. { info :: ResultInfo
|
||||
, name :: String
|
||||
, moduleName :: String
|
||||
| rest
|
||||
}
|
||||
-> Array (HH.HTML a Action)
|
||||
renderResultType = \result ->
|
||||
renderResultType result =
|
||||
case result.info of
|
||||
ValueResult {type:ty} ->
|
||||
[ HH.pre [ HP.class_ (wrap "result__signature") ]
|
||||
[ HH.code_ [ HH.text (result.name <> " :: ")
|
||||
, renderType ty ]
|
||||
]
|
||||
]
|
||||
_ -> []
|
||||
ValueResult { type: ty } ->
|
||||
wrapSignature [ HH.a [ makeHref ValueLevel false result.moduleName result.name ]
|
||||
[ HH.text result.name ]
|
||||
, HH.text " :: "
|
||||
, renderType ty ]
|
||||
|
||||
renderType :: forall a. Type -> HH.HTML a Action
|
||||
TypeClassMemberResult info ->
|
||||
wrapSignature $ renderTypeClassMemberSignature info result
|
||||
|
||||
TypeClassResult info ->
|
||||
wrapSignature $ renderTypeClassResult info result
|
||||
_ -> []
|
||||
where
|
||||
wrapSignature signature =
|
||||
[ HH.pre [ HP.class_ (wrap "result__signature") ] [ HH.code_ signature ] ]
|
||||
|
||||
renderTypeClassResult
|
||||
:: forall a rest
|
||||
. { fundeps :: FunDeps
|
||||
, arguments :: Array TypeArgument
|
||||
, superclasses :: Array Constraint
|
||||
}
|
||||
-> { name :: String, moduleName :: String | rest }
|
||||
-> Array (HH.HTML a Action)
|
||||
renderTypeClassResult { fundeps, arguments, superclasses } { name, moduleName } =
|
||||
[ keyword "class"
|
||||
, if Array.null superclasses
|
||||
then
|
||||
HH.text ""
|
||||
else
|
||||
HH.span_ $
|
||||
[ syntax " ("
|
||||
, HH.span_ $ Array.intercalate [ HH.text ", " ] (
|
||||
superclasses <#> renderConstraint >>> Array.singleton
|
||||
)
|
||||
, syntax ")"
|
||||
, HH.text " "
|
||||
, syntax "<="
|
||||
]
|
||||
, HH.text " "
|
||||
, HH.a [ makeHref TypeLevel false moduleName name ]
|
||||
[ HH.text name ]
|
||||
, HH.text " "
|
||||
] <> (
|
||||
Array.intercalate [ HH.text " " ] (
|
||||
arguments <#> (
|
||||
unwrap >>>
|
||||
\argument ->
|
||||
case argument.mbKind of
|
||||
Nothing ->
|
||||
[ HH.text argument.name ]
|
||||
Just kind ->
|
||||
[ HH.text "("
|
||||
, HH.text argument.name
|
||||
, HH.text " :: "
|
||||
, renderKind kind
|
||||
, HH.text ")"
|
||||
]))
|
||||
)
|
||||
|
||||
-- | Insert type class name and arguments
|
||||
renderTypeClassMemberSignature
|
||||
:: forall a rest
|
||||
. { type :: Type
|
||||
, typeClass :: String
|
||||
, typeClassArguments :: Array String
|
||||
}
|
||||
-> { name :: String | rest }
|
||||
-> Array (HH.HTML a Action)
|
||||
renderTypeClassMemberSignature { type: ty, typeClass, typeClassArguments } result =
|
||||
[ HH.text result.name
|
||||
, HH.text " :: "
|
||||
, HH.text $ typeClass <> " "
|
||||
-- We don't want to insert `forall` here to avoid visual noise,
|
||||
-- and to make type class members more easily distinguishable from ordinary values.
|
||||
-- TODO: consider doing what pursuit does.
|
||||
, HH.text $ Array.intercalate " " typeClassArguments <> " "
|
||||
, HH.text "=> "
|
||||
, renderType ty ]
|
||||
|
||||
renderType
|
||||
:: forall a
|
||||
. Type
|
||||
-> HH.HTML a Action
|
||||
renderType = case _ of
|
||||
TypeVar str -> HH.text str
|
||||
TypeLevelString str -> HH.text str
|
||||
TypeLevelString str -> HH.text $ "(Text \"" <> str <> "\")" -- TODO: add escaping
|
||||
TypeWildcard -> HH.text "_"
|
||||
TypeConstructor qname -> renderQualifiedName qname
|
||||
TypeOp qname -> renderQualifiedName qname
|
||||
TypeConstructor qname -> renderQualifiedName false TypeLevel qname
|
||||
TypeOp qname -> renderQualifiedName true TypeLevel qname
|
||||
|
||||
TypeApp (TypeApp (TypeConstructor
|
||||
(QualifiedName { moduleName: ["Prim"]
|
||||
(QualifiedName { moduleName: [ "Prim" ]
|
||||
, name: "Function" })) t1) t2 ->
|
||||
HH.span_ [ renderType t1
|
||||
, HH.text " -> "
|
||||
, renderType t2
|
||||
]
|
||||
|
||||
TypeApp (TypeConstructor (QualifiedName { moduleName: ["Prim"]
|
||||
TypeApp (TypeConstructor (QualifiedName { moduleName: [ "Prim" ]
|
||||
, name: "Record" }))
|
||||
record ->
|
||||
HH.span_ [ HH.text "{ | "
|
||||
, renderType record
|
||||
, HH.text " }" ]
|
||||
|
||||
row ->
|
||||
renderRow false row
|
||||
|
||||
TypeApp t1 t2 ->
|
||||
HH.span_ [ renderType t1
|
||||
@ -298,20 +416,7 @@ renderType = case _ of
|
||||
]
|
||||
|
||||
ty@(ForAll _ _ _) ->
|
||||
let foralls = joinForAlls ty in
|
||||
HH.span_ $
|
||||
[ HH.text "forall" ] <>
|
||||
( Array.fromFoldable foralls.binders <#>
|
||||
\ { var, mbKind } ->
|
||||
case mbKind of
|
||||
Nothing -> HH.text (" " <> var)
|
||||
Just kind ->
|
||||
HH.span_ [ HH.text ("(" <> var <> " :: ")
|
||||
, renderKind kind
|
||||
, HH.text ")"
|
||||
]
|
||||
) <>
|
||||
[ HH.text ". ", renderType foralls.ty ]
|
||||
renderForAll ty
|
||||
|
||||
ConstrainedType cnstr ty ->
|
||||
HH.span_
|
||||
@ -320,15 +425,18 @@ renderType = case _ of
|
||||
, renderType ty
|
||||
]
|
||||
|
||||
REmpty -> HH.text "{}"
|
||||
ty@(RCons _ _ _) -> renderRow ty
|
||||
ty@REmpty -> renderRow true ty
|
||||
ty@(RCons _ _ _) -> renderRow true ty
|
||||
|
||||
BinaryNoParensType op t1 t2 ->
|
||||
HH.span_
|
||||
[ renderType t1
|
||||
, HH.text " "
|
||||
, renderType op
|
||||
, HH.text " "
|
||||
, renderType t2
|
||||
]
|
||||
|
||||
ParensInType ty ->
|
||||
HH.span_
|
||||
[ HH.text "("
|
||||
@ -336,39 +444,123 @@ renderType = case _ of
|
||||
, HH.text ")"
|
||||
]
|
||||
|
||||
renderRow :: forall a. Type -> HH.HTML a Action
|
||||
renderRow ty =
|
||||
let rows = joinRows ty in
|
||||
renderForAll
|
||||
:: forall a
|
||||
. Type
|
||||
-> HH.HTML a Action
|
||||
renderForAll ty =
|
||||
HH.span_ $
|
||||
[ HH.text "{ " ] <>
|
||||
( Array.intercalate [ HH.text ", " ] $ Array.fromFoldable rows <#>
|
||||
\entry ->
|
||||
[ HH.span_ [ HH.text $ entry.row <> " :: "
|
||||
, renderType entry.ty ] ]
|
||||
|
||||
[ HH.text "forall" ] <>
|
||||
|
||||
( Array.fromFoldable foralls.binders <#>
|
||||
\ { var, mbKind } ->
|
||||
case mbKind of
|
||||
Nothing -> HH.text (" " <> var)
|
||||
Just kind ->
|
||||
HH.span_ [ HH.text $ " (" <> var <> " :: "
|
||||
, renderKind kind
|
||||
, HH.text ")" ]
|
||||
) <>
|
||||
[ HH.text " }" ]
|
||||
|
||||
htmlSingleton :: forall t406 t407. HH.HTML t407 t406 -> HH.HTML t407 t406
|
||||
htmlSingleton x = HH.span_ [ x ]
|
||||
[ HH.text ". ", renderType foralls.ty ]
|
||||
|
||||
renderConstraint :: forall a. Constraint -> HH.HTML a Action
|
||||
where
|
||||
foralls = joinForAlls ty
|
||||
|
||||
renderRow
|
||||
:: forall a
|
||||
. Boolean
|
||||
-> Type
|
||||
-> HH.HTML a Action
|
||||
renderRow asRow =
|
||||
joinRows >>> \ { rows, ty } ->
|
||||
|
||||
HH.span_ $
|
||||
|
||||
if List.null rows
|
||||
then
|
||||
[ HH.text $ if asRow then "()" else "{}" ]
|
||||
else
|
||||
[ HH.text opening ] <>
|
||||
|
||||
( Array.intercalate [ HH.text ", " ] $ Array.fromFoldable $ rows <#>
|
||||
\entry ->
|
||||
[ HH.span_ [ HH.text $ entry.row <> " :: "
|
||||
, renderType entry.ty ] ]
|
||||
) <>
|
||||
|
||||
case ty of
|
||||
Just ty' -> [ HH.text " | ", renderType ty', HH.text closing ]
|
||||
Nothing -> [ HH.text closing ]
|
||||
|
||||
where
|
||||
opening = if asRow then "( " else "{ "
|
||||
closing = if asRow then " )" else " }"
|
||||
|
||||
renderConstraint
|
||||
:: forall a
|
||||
. Constraint
|
||||
-> HH.HTML a Action
|
||||
renderConstraint (Constraint { constraintClass, constraintArgs }) =
|
||||
HH.span_ $
|
||||
[ renderQualifiedName constraintClass, HH.text " " ] <>
|
||||
[ renderQualifiedName false TypeLevel constraintClass, HH.text " " ] <>
|
||||
Array.intercalate [ HH.text " " ] (constraintArgs <#> \ty -> [ renderType ty ])
|
||||
|
||||
renderQualifiedName
|
||||
:: forall a
|
||||
. Boolean
|
||||
-> DeclLevel
|
||||
-> QualifiedName
|
||||
-> HH.HTML a Action
|
||||
renderQualifiedName isInfix level (QualifiedName { moduleName, name })
|
||||
= if isBuiltIn then
|
||||
HH.text name
|
||||
else
|
||||
HH.a [ HE.onClick $ const $ Just $
|
||||
SearchResultClicked $ moduleNameString
|
||||
, makeHref level isInfix moduleNameString name
|
||||
]
|
||||
[ HH.text name ]
|
||||
where
|
||||
moduleNameString = Array.intercalate "." moduleName
|
||||
isBuiltIn = moduleName !! 0 == Just "Prim"
|
||||
|
||||
renderQualifiedName :: forall a. QualifiedName -> HH.HTML a Action
|
||||
renderQualifiedName (QualifiedName { moduleName, name })
|
||||
= HH.text name
|
||||
|
||||
renderKind :: forall a. Kind -> HH.HTML a Action
|
||||
renderKind
|
||||
:: forall a
|
||||
. Kind ->
|
||||
HH.HTML a Action
|
||||
renderKind = case _ of
|
||||
Row k1 -> HH.span_ [ HH.text "#", renderKind k1 ]
|
||||
FunKind k1 k2 -> HH.span_ [ renderKind k1, renderKind k2 ]
|
||||
NamedKind qname -> renderQualifiedName qname
|
||||
Row k1 -> HH.span_ [ HH.text "# ", renderKind k1 ]
|
||||
FunKind k1 k2 -> HH.span_ [ renderKind k1, HH.text " -> ", renderKind k2 ]
|
||||
NamedKind qname -> renderQualifiedName false KindLevel qname
|
||||
|
||||
isValuableQuery :: TypeQuery -> Boolean
|
||||
isValuableQuery (QVar _) = false
|
||||
isValuableQuery (QConst _) = false
|
||||
isValuableQuery _ = true
|
||||
makeHref
|
||||
:: forall t rest
|
||||
. DeclLevel
|
||||
-> Boolean
|
||||
-> String
|
||||
-> String
|
||||
-> HH.IProp ( href :: String | rest ) t
|
||||
makeHref level isInfix moduleName name =
|
||||
HP.href $
|
||||
moduleName <> ".html#" <>
|
||||
declLevelToHashAnchor level <> ":" <>
|
||||
if isInfix then "type (" <> name <> ")" else name
|
||||
|
||||
keyword
|
||||
:: forall a
|
||||
. String
|
||||
-> HH.HTML a Action
|
||||
keyword str = HH.span [ HP.class_ (wrap "keyword") ] [ HH.text str ]
|
||||
|
||||
syntax
|
||||
:: forall a
|
||||
. String
|
||||
-> HH.HTML a Action
|
||||
syntax str = HH.span [ HP.class_ (wrap "syntax") ] [ HH.text str ]
|
||||
|
||||
isValuableTypeQuery :: TypeQuery -> Boolean
|
||||
isValuableTypeQuery (QVar _) = false
|
||||
isValuableTypeQuery (QConst _) = false
|
||||
isValuableTypeQuery _ = true
|
||||
|
||||
@ -2,8 +2,14 @@ module Spago.Search.Extra where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Data.Foldable (class Foldable, foldMap)
|
||||
import Data.Maybe (Maybe(..))
|
||||
|
||||
whenJust :: forall a m. Monad m => Maybe a -> (a -> m Unit) -> m Unit
|
||||
whenJust (Just a) f = f a
|
||||
whenJust _ _ = pure unit
|
||||
|
||||
foldMapFlipped :: forall a m f. Foldable f => Monoid m => f a -> (a -> m) -> m
|
||||
foldMapFlipped = flip foldMap
|
||||
|
||||
infixr 7 foldMapFlipped as >#>
|
||||
|
||||
@ -11,7 +11,7 @@ import Data.List (List, (:))
|
||||
import Data.List as List
|
||||
import Data.Maybe (Maybe(..), fromMaybe)
|
||||
import Data.Newtype (class Newtype, unwrap)
|
||||
import Data.Search.Trie (Trie, alter, entriesUnordered, fromList, insert)
|
||||
import Data.Search.Trie (Trie, alter, entriesUnordered)
|
||||
import Data.String.CodeUnits (stripPrefix, stripSuffix, toCharArray)
|
||||
import Data.String.Common (toLower)
|
||||
import Data.String.Common as String
|
||||
@ -31,7 +31,9 @@ data ResultInfo
|
||||
| ExternDataResult { kind :: Kind }
|
||||
| TypeSynonymResult { type :: Type }
|
||||
| DataConstructorResult { arguments :: Array Type }
|
||||
| TypeClassMemberResult { type :: Type }
|
||||
| TypeClassMemberResult { type :: Type
|
||||
, typeClass :: String
|
||||
, typeClassArguments :: Array String }
|
||||
| TypeClassResult { fundeps :: FunDeps
|
||||
, arguments :: Array TypeArgument
|
||||
, superclasses :: Array Constraint }
|
||||
@ -131,27 +133,30 @@ resultsForEntry
|
||||
-> List { path :: String
|
||||
, result :: SearchResult
|
||||
}
|
||||
resultsForEntry moduleName ie@(IndexEntry entry@{info, title, sourceSpan, comments, children}) =
|
||||
let { name, declLevel } = getLevelAndName info.declType title
|
||||
resultsForEntry moduleName indexEntry@(IndexEntry entry) =
|
||||
let { info, title, sourceSpan, comments, children } = entry
|
||||
{ name, declLevel } = getLevelAndName info.declType title
|
||||
packageName = extractPackageName sourceSpan.name
|
||||
in case mkInfo declLevel ie of
|
||||
in case mkInfo declLevel indexEntry of
|
||||
Nothing -> mempty
|
||||
Just info' -> (
|
||||
List.singleton $
|
||||
{ path: name
|
||||
, result: SearchResult { name: title
|
||||
, comments
|
||||
, hashAnchor: declLevelToHashAnchor declLevel
|
||||
, moduleName
|
||||
, sourceSpan: Just sourceSpan
|
||||
, packageName
|
||||
, info: info'
|
||||
}
|
||||
}
|
||||
) <>
|
||||
( List.fromFoldable children >>=
|
||||
resultsForChildIndexEntry packageName moduleName
|
||||
)
|
||||
Just info' ->
|
||||
let result = SearchResult { name: title
|
||||
, comments
|
||||
, hashAnchor: declLevelToHashAnchor declLevel
|
||||
, moduleName
|
||||
, sourceSpan: Just sourceSpan
|
||||
, packageName
|
||||
, info: info'
|
||||
}
|
||||
in
|
||||
( List.singleton $
|
||||
{ path: name
|
||||
, result
|
||||
}
|
||||
) <>
|
||||
( List.fromFoldable children >>=
|
||||
resultsForChildIndexEntry packageName moduleName result
|
||||
)
|
||||
|
||||
mkInfo :: DeclLevel -> IndexEntry -> Maybe ResultInfo
|
||||
mkInfo declLevel (IndexEntry { info, title }) =
|
||||
@ -240,11 +245,12 @@ extractPackageName name =
|
||||
resultsForChildIndexEntry
|
||||
:: String
|
||||
-> String
|
||||
-> SearchResult
|
||||
-> ChildIndexEntry
|
||||
-> List { path :: String, result :: SearchResult }
|
||||
resultsForChildIndexEntry packageName moduleName
|
||||
cie@(ChildIndexEntry { title, info, comments, mbSourceSpan }) =
|
||||
case mkChildInfo cie of
|
||||
resultsForChildIndexEntry packageName moduleName parentResult
|
||||
child@(ChildIndexEntry { title, info, comments, mbSourceSpan }) =
|
||||
case mkChildInfo parentResult child of
|
||||
Nothing -> mempty
|
||||
Just resultInfo ->
|
||||
{ path: title
|
||||
@ -258,13 +264,21 @@ resultsForChildIndexEntry packageName moduleName
|
||||
}
|
||||
} # List.singleton
|
||||
|
||||
mkChildInfo :: ChildIndexEntry -> Maybe ResultInfo
|
||||
mkChildInfo (ChildIndexEntry { info } ) =
|
||||
mkChildInfo :: SearchResult -> ChildIndexEntry -> Maybe ResultInfo
|
||||
mkChildInfo parentResult (ChildIndexEntry { info } ) =
|
||||
case info.declType of
|
||||
ChildDeclDataConstructor ->
|
||||
info.arguments <#>
|
||||
\arguments -> DataConstructorResult { arguments }
|
||||
ChildDeclTypeClassMember ->
|
||||
info.type <#>
|
||||
\ty -> TypeClassMemberResult { type: ty }
|
||||
-- We need to get the name and the type arguments of a parent class.
|
||||
case (unwrap parentResult).info of
|
||||
TypeClassResult { arguments } ->
|
||||
info.type <#>
|
||||
\ty -> TypeClassMemberResult
|
||||
{ type: ty
|
||||
, typeClass: (unwrap parentResult).name
|
||||
, typeClassArguments: arguments <#> unwrap >>> (_.name)
|
||||
}
|
||||
_ -> Nothing
|
||||
ChildDeclInstance -> Nothing
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
module Spago.Seach.IndexBuilder where
|
||||
module Spago.Search.IndexBuilder where
|
||||
|
||||
import Prelude
|
||||
|
||||
@ -96,4 +96,9 @@ main = do
|
||||
writeDeclarations declarations
|
||||
patchDocs
|
||||
let index = mkSearchIndex declarations
|
||||
liftEffect $ log $ "Loaded " <> show (Trie.size $ (unwrap index).decls) <> " definitions"
|
||||
liftEffect $ log $
|
||||
"Loaded " <>
|
||||
show (Trie.size $ (unwrap index).decls) <>
|
||||
" definitions and " <>
|
||||
show (Trie.size $ (unwrap index).types) <>
|
||||
" type definitions"
|
||||
|
||||
@ -8,7 +8,8 @@ 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.String.Common (trim) as String
|
||||
import Data.List (List(..), many, some, (:))
|
||||
import Data.List as List
|
||||
import Data.List.NonEmpty (NonEmptyList, cons', uncons)
|
||||
import Data.List.NonEmpty as NonEmptyList
|
||||
@ -26,7 +27,7 @@ data TypeQuery
|
||||
| QFun TypeQuery TypeQuery
|
||||
| QApp TypeQuery TypeQuery
|
||||
| QForAll (NonEmptyList String) TypeQuery
|
||||
| QConstraint String (List String) TypeQuery
|
||||
| QConstraint String (List TypeQuery) TypeQuery
|
||||
| QRow (List (Tuple String TypeQuery))
|
||||
|
||||
derive instance eqTypeQuery :: Eq TypeQuery
|
||||
@ -36,7 +37,7 @@ instance showTypeQuery :: Show TypeQuery where
|
||||
show x = genericShow x
|
||||
|
||||
parseTypeQuery :: String -> Either ParseError TypeQuery
|
||||
parseTypeQuery = runParser (typeQueryParser <* eof)
|
||||
parseTypeQuery = String.trim >>> runParser (typeQueryParser <* eof)
|
||||
|
||||
typeQueryParser :: Parser TypeQuery
|
||||
typeQueryParser = fix \typeQuery ->
|
||||
@ -45,7 +46,9 @@ typeQueryParser = fix \typeQuery ->
|
||||
(skipSpaces *> typeQuery <* skipSpaces))
|
||||
(string "," *> skipSpaces)
|
||||
|
||||
row = string "{" *> rowFields <* string "}"
|
||||
row = string "(" *> rowFields <* string ")"
|
||||
|
||||
record = QApp (QConst "Record") <$> (string "{" *> rowFields <* string "}")
|
||||
|
||||
binders =
|
||||
string "forall" *> some space *> sepEndBy1 ident (some space) <* string "." <* skipSpaces
|
||||
@ -57,8 +60,9 @@ typeQueryParser = fix \typeQuery ->
|
||||
|
||||
atom = skipSpaces *> (
|
||||
for_all <|>
|
||||
parens <|>
|
||||
try parens <|>
|
||||
row <|>
|
||||
record <|>
|
||||
concrete <|>
|
||||
any
|
||||
)
|
||||
@ -71,7 +75,7 @@ typeQueryParser = fix \typeQuery ->
|
||||
|
||||
constrained =
|
||||
QConstraint <$> (upperCaseIdent <* some space) <*>
|
||||
(sepEndBy ident (some space) <* string "=>" <* skipSpaces) <*>
|
||||
(sepEndBy ((QVar <$> ident) <|> parens) (many space) <* string "=>" <* skipSpaces) <*>
|
||||
typeQuery
|
||||
in
|
||||
try constrained <|> funs
|
||||
@ -101,19 +105,19 @@ concrete =
|
||||
ident :: Parser String
|
||||
ident = do
|
||||
head <- anyLetter
|
||||
rest <- Array.many alphaNum
|
||||
rest <- Array.many (alphaNum <|> char '\'')
|
||||
pure $ fromCharArray $ pure head <> rest
|
||||
|
||||
upperCaseIdent :: Parser String
|
||||
upperCaseIdent = do
|
||||
head <- upperCaseChar
|
||||
rest <- Array.many alphaNum
|
||||
rest <- Array.many (alphaNum <|> char '\'')
|
||||
pure $ fromCharArray $ pure head <> rest
|
||||
|
||||
lowerCaseIdent :: Parser String
|
||||
lowerCaseIdent = do
|
||||
head <- lowerCaseChar
|
||||
rest <- Array.many alphaNum
|
||||
rest <- Array.many (alphaNum <|> char '\'')
|
||||
pure $ fromCharArray $ pure head <> rest
|
||||
|
||||
space :: Parser Char
|
||||
@ -152,7 +156,7 @@ getFreeVariables query = go Set.empty Set.empty (List.singleton $ Next query)
|
||||
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 <$> vars) <> (Next q : rest))
|
||||
|
||||
go bound free (Next (QRow lst) : rest) =
|
||||
go bound free ((lst <#> snd >>> Next) <> rest)
|
||||
|
||||
@ -11,7 +11,7 @@ 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.Maybe (Maybe(..))
|
||||
import Data.Set as Set
|
||||
import Data.Tuple (Tuple(..), snd)
|
||||
|
||||
@ -108,10 +108,11 @@ shapeOfType ty = List.reverse $ go (pure ty) Nil
|
||||
go rest (PVar : acc)
|
||||
|
||||
row@(RCons _ _ _) ->
|
||||
go (typesInRow <> rest) (PRow (List.length joined) : acc)
|
||||
go (typesInRow <> rest) (PRow (List.length joined.rows) : acc)
|
||||
where
|
||||
joined = List.sortBy (\x y -> compare x.row y.row) $ joinRows row
|
||||
typesInRow = joined <#> (_.ty)
|
||||
joined = joinRows row
|
||||
sorted = List.sortBy (\x y -> compare x.row y.row) $ joined.rows
|
||||
typesInRow = sorted <#> (_.ty)
|
||||
|
||||
BinaryNoParensType op l r ->
|
||||
go (TypeApp (TypeApp op l) r : rest) acc
|
||||
@ -128,11 +129,17 @@ joinForAlls ty = go Nil ty
|
||||
go ({ var, mbKind } : acc) ty'
|
||||
go acc ty' = { binders: acc, ty: ty' }
|
||||
|
||||
joinRows :: Type -> List { row :: String
|
||||
, ty :: Type
|
||||
}
|
||||
joinRows :: Type -> { rows :: List { row :: String
|
||||
, ty :: Type
|
||||
}
|
||||
, ty :: Maybe Type }
|
||||
joinRows = go Nil
|
||||
where
|
||||
go acc (RCons row ty rest) =
|
||||
go ({ row, ty } : acc) rest
|
||||
go acc _ = List.reverse acc
|
||||
go acc ty = { rows: List.reverse acc
|
||||
, ty:
|
||||
case ty of
|
||||
REmpty -> Nothing
|
||||
ty' -> Just ty'
|
||||
}
|
||||
|
||||
@ -5,20 +5,27 @@ 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 Effect (Effect)
|
||||
import Effect.Aff (Aff, launchAff_)
|
||||
import Effect.Class (liftEffect)
|
||||
import Effect.Console (log)
|
||||
import Test.TypeQuery as TypeQuery
|
||||
import Test.TypeShape as TypeShape
|
||||
import Test.Unit (suite, test)
|
||||
import Test.Unit.Assert as Assert
|
||||
import Test.Unit.Main (runTest)
|
||||
import Test.TypeQuery as TypeQuery
|
||||
import Test.Unit.Main (run, runTest)
|
||||
|
||||
main :: Effect Unit
|
||||
main = runTest do
|
||||
main = do
|
||||
runTest mainTest
|
||||
|
||||
mainTest = do
|
||||
TypeQuery.tests
|
||||
|
||||
let mkJson x = unsafePartial $ fromRight $ jsonParser x
|
||||
|
||||
@ -104,19 +104,19 @@ tests = do
|
||||
let input = "forall m a. Monad m => a -> m a"
|
||||
assertRight (parseTypeQuery input)
|
||||
(QForAll (nl "m" ["a"])
|
||||
(QConstraint "Monad" (l ["m"])
|
||||
(QConstraint "Monad" (l [QVar "m"])
|
||||
(QFun (QVar "a")
|
||||
(QApp (QVar "m") (QVar "a")))))
|
||||
|
||||
test "test #19" do
|
||||
let input = "{ a :: Int }"
|
||||
assertRight (parseTypeQuery input)
|
||||
(QRow (pure (Tuple "a" (QConst "Int"))))
|
||||
(QApp (QConst "Record") (QRow (pure (Tuple "a" (QConst "Int")))))
|
||||
|
||||
test "test #20" do
|
||||
let input = "{a::Int}"
|
||||
assertRight (parseTypeQuery input)
|
||||
(QRow (pure (Tuple "a" (QConst "Int"))))
|
||||
(QApp (QConst "Record") (QRow (pure (Tuple "a" (QConst "Int")))))
|
||||
|
||||
test "test #21" do
|
||||
let input = "Int"
|
||||
@ -129,7 +129,7 @@ tests = do
|
||||
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)
|
||||
(QConstraint "MonadRec" (l [QVar "m"])
|
||||
(QFun (QApp (QApp (QConst "Process")
|
||||
(QVar "m")) (QVar "a"))
|
||||
(QApp (QVar "m") (QVar "a")))))
|
||||
@ -137,17 +137,31 @@ tests = do
|
||||
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"))))
|
||||
(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" ("m" : Nil)
|
||||
(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"))))
|
||||
|
||||
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")))))))
|
||||
|
||||
suite "polish notation" do
|
||||
|
||||
test "test #1" do
|
||||
|
||||
90
test/Test/TypeShape.purs
Normal file
90
test/Test/TypeShape.purs
Normal file
@ -0,0 +1,90 @@
|
||||
module Test.TypeShape where
|
||||
|
||||
import Data.Either
|
||||
import Data.Either
|
||||
import Data.Maybe
|
||||
import Effect.Aff
|
||||
import Partial.Unsafe
|
||||
import Prelude
|
||||
import Spago.Search.DocsJson
|
||||
import Spago.Search.Index
|
||||
import Spago.Search.IndexBuilder
|
||||
import Spago.Search.TypeDecoder
|
||||
import Spago.Search.TypeQuery
|
||||
import Spago.Search.TypeShape
|
||||
|
||||
import Data.Array as Array
|
||||
import Data.List as List
|
||||
import Data.Maybe (Maybe(..))
|
||||
import Data.Newtype (unwrap)
|
||||
import Data.Search.Trie as Trie
|
||||
import Data.Traversable (for, for_)
|
||||
import Effect (Effect)
|
||||
import Effect.Aff (Aff, launchAff_)
|
||||
import Effect.Class (liftEffect)
|
||||
import Effect.Console (log, logShow)
|
||||
import Node.Encoding (Encoding(UTF8))
|
||||
import Node.FS.Aff (exists, readTextFile, readdir, writeTextFile)
|
||||
import Node.Process as Process
|
||||
import Test.TypeQuery as TypeQuery
|
||||
import Test.Unit (suite, test)
|
||||
import Test.Unit.Assert as Assert
|
||||
import Test.Unit.Main (runTest)
|
||||
|
||||
-- | Crash-testing query parser on existing types.
|
||||
run :: Aff Unit
|
||||
run = do
|
||||
paths <- readdir "output"
|
||||
declarations <- collectDeclarations paths
|
||||
-- liftEffect $ log $ "Found " <> show (Array.length declarations) <> " modules"
|
||||
let index = mkSearchIndex declarations
|
||||
let types = Trie.values ((unwrap index).types)
|
||||
for_ types \tys -> do
|
||||
for_ tys \ty -> do
|
||||
case (unwrap ty).info of
|
||||
ValueResult { type: ty } -> do
|
||||
let shown = showType ty
|
||||
case parseTypeQuery shown of
|
||||
Left err ->
|
||||
liftEffect $ log $ show err <> ": \n" <> shown
|
||||
_ ->
|
||||
pure unit
|
||||
_ -> pure unit
|
||||
|
||||
showType :: Type -> String
|
||||
showType = case _ of
|
||||
TypeVar _String -> _String
|
||||
TypeLevelString _String ->
|
||||
_String
|
||||
TypeWildcard ->
|
||||
"_"
|
||||
TypeConstructor _QualifiedName ->
|
||||
showQualifiedName _QualifiedName
|
||||
TypeOp _QualifiedName ->
|
||||
showQualifiedName _QualifiedName
|
||||
TypeApp (TypeApp (TypeConstructor (QualifiedName { moduleName: ["Prim"]
|
||||
, name: "Function" })) t1) t2 ->
|
||||
showType t1 <> " -> " <> showType t2
|
||||
|
||||
TypeApp _Type1 _Type2 ->
|
||||
showType _Type1 <> " " <> showType _Type2
|
||||
foralls@(ForAll _String _Type _Maybe_Kind) ->
|
||||
let joined = joinForAlls foralls in
|
||||
"forall " <> (List.intercalate " " $ joined.binders <#> (_.var)) <> ". " <> showType joined.ty -- <> " " <> show _Maybe_Kind
|
||||
ConstrainedType _Constraint _Type ->
|
||||
showConstraint _Constraint <> " => " <> showType _Type
|
||||
REmpty ->
|
||||
"{}"
|
||||
RCons _String _Type1 _Type2 ->
|
||||
"(RConsLabel " <> _String <> " " <> showType _Type1 <> " " <> showType _Type2 <> ")"
|
||||
BinaryNoParensType _TypeOp _Type1 _Type2 ->
|
||||
showType _Type1 <> " " <> showType _TypeOp <> " " <> showType _Type2
|
||||
ParensInType _Type ->
|
||||
"(" <> showType _Type <> ")"
|
||||
|
||||
showQualifiedName :: QualifiedName -> String
|
||||
showQualifiedName = unwrap >>> (_.name)
|
||||
|
||||
showConstraint :: Constraint -> String
|
||||
showConstraint (Constraint { constraintClass, constraintArgs }) =
|
||||
showQualifiedName constraintClass <> " " <> Array.intercalate " " (constraintArgs <#> showType)
|
||||
Loading…
Reference in New Issue
Block a user