From b16928cd8571c052e36a5d3c67d16cc58caa44ee Mon Sep 17 00:00:00 2001
From: Phil Freeman <paf31@cantab.net>
Date: Sat, 14 Jan 2017 14:44:39 -0800
Subject: [PATCH 1/2] First stab at type search
---
server/Main.hs | 51 +++++++++++++++++++++++++++++++++++++++++++--
stack.yaml | 4 ++--
trypurescript.cabal | 5 +++--
3 files changed, 54 insertions(+), 6 deletions(-)
diff --git a/server/Main.hs b/server/Main.hs
index b33d831e..713b4320 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -1,22 +1,26 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Main (main) where
-import Control.Monad (unless)
+import Control.Monad (unless, (>=>))
+import Control.Monad.Error.Class (throwError)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (runLogger')
+import Control.Monad.State (State)
+import qualified Control.Monad.State as State
import Control.Monad.Trans (lift)
-import Control.Monad.Error.Class (throwError)
import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
import Control.Monad.Trans.Reader (runReaderT)
import qualified Data.Aeson as A
import Data.Aeson ((.=))
import qualified Data.ByteString.Lazy as BL
import Data.List (foldl')
+import qualified Data.Map as M
import Data.String (fromString)
import Data.Text (Text)
import qualified Data.Text as T
@@ -30,12 +34,14 @@ import qualified Language.PureScript.CodeGen.JS as J
import qualified Language.PureScript.CoreFn as CF
import qualified Language.PureScript.Errors.JSON as P
import qualified Language.PureScript.Interactive as I
+import qualified Language.PureScript.TypeChecker.TypeSearch as TS
import System.Environment (getArgs)
import System.Exit (exitFailure)
import System.FilePath ((</>))
import System.FilePath.Glob (glob)
import qualified System.IO as IO
import System.IO.UTF8 (readUTF8File)
+import qualified Text.Parsec.Combinator as Parsec
import Web.Scotty
import qualified Web.Scotty as Scotty
@@ -90,6 +96,47 @@ server bundled externs initEnv port = do
Scotty.json $ A.object [ "error" .= err ]
Right comp ->
Scotty.json $ A.object [ "js" .= comp ]
+ get "/search" $ do
+ query <- param "q"
+ case tryParseType query of
+ Nothing -> Scotty.json $ A.object [ "error" .= ("Cannot parse type" :: Text) ]
+ Just ty -> do
+ let ty' = replaceTypeVariablesAndDesugar ty
+ let results = TS.typeSearch (Just []) initEnv (P.emptyCheckState initEnv) ty'
+ Scotty.json $ A.object [ "results" .= A.object [ P.showQualified P.runIdent k .= P.prettyPrintType v
+ | (k, v) <- take 20 (M.toList results)
+ ]
+ ]
+
+-- | (Consistently) replace unqualified type constructors and type variables with unknowns.
+--
+-- Also remove the @ParensInType@ Constructor (we need to deal with type operators later at some point).
+replaceTypeVariablesAndDesugar :: P.Type -> P.Type
+replaceTypeVariablesAndDesugar ty = State.evalState (P.everywhereOnTypesM go ty) (0, M.empty) where
+ go = \case
+ P.ParensInType ty -> pure ty
+ P.TypeConstructor (P.Qualified Nothing tyCon) -> do
+ (next, m) <- State.get
+ case M.lookup (Left tyCon) m of
+ Nothing -> do
+ let ty = P.TUnknown next
+ State.put (next + 1, M.insert (Left tyCon) ty m)
+ pure ty
+ Just ty -> pure ty
+ P.TypeVar s -> do
+ (next, m) <- State.get
+ case M.lookup (Right s) m of
+ Nothing -> do
+ let ty = P.TUnknown next
+ State.put (next + 1, M.insert (Right s) ty m)
+ pure ty
+ Just ty -> pure ty
+ other -> pure other
+
+tryParseType :: Text -> Maybe P.Type
+tryParseType = hush (P.lex "") >=> hush (P.runTokenParser "" (P.parsePolyType <* Parsec.eof))
+ where
+ hush f = either (const Nothing) Just . f
bundle :: IO (Either Bundle.ErrorMessage String)
bundle = runExceptT $ do
diff --git a/stack.yaml b/stack.yaml
index 5727cb7e..daa0b481 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -3,7 +3,7 @@ flags: {}
packages:
- '.'
extra-deps:
-- purescript-0.10.4
-- bower-json-0.8.0
+- purescript-0.10.5
+- bower-json-1.0.0.1
- language-javascript-0.6.0.9
- parsec-3.1.11
diff --git a/trypurescript.cabal b/trypurescript.cabal
index bbe911c3..490ba0d8 100644
--- a/trypurescript.cabal
+++ b/trypurescript.cabal
@@ -1,5 +1,5 @@
name: trypurescript
-version: 0.10.4
+version: 0.10.5
cabal-version: >=1.8
build-type: Simple
license: BSD3
@@ -20,11 +20,12 @@ executable trypurescript
filepath -any,
Glob -any,
scotty -any,
- purescript ==0.10.4,
+ purescript ==0.10.5,
containers -any,
http-types >= 0.8.5,
transformers ==0.4.*,
mtl ==2.2.1,
+ parsec,
text -any,
time -any
hs-source-dirs: server
From a99d0f3307f5970e8793126820251354704ee9f4 Mon Sep 17 00:00:00 2001
From: Phil Freeman <paf31@cantab.net>
Date: Sat, 14 Jan 2017 15:29:37 -0800
Subject: [PATCH 2/2] Replace type constructors first, prefer strict matches
---
server/Main.hs | 50 +++++++++++++++++++++++++++++++-------------------
1 file changed, 31 insertions(+), 19 deletions(-)
diff --git a/server/Main.hs b/server/Main.hs
index 713b4320..7ecc8b46 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -19,7 +19,8 @@ import Control.Monad.Trans.Reader (runReaderT)
import qualified Data.Aeson as A
import Data.Aeson ((.=))
import qualified Data.ByteString.Lazy as BL
-import Data.List (foldl')
+import Data.Function (on)
+import Data.List (foldl', nubBy)
import qualified Data.Map as M
import Data.String (fromString)
import Data.Text (Text)
@@ -98,37 +99,48 @@ server bundled externs initEnv port = do
Scotty.json $ A.object [ "js" .= comp ]
get "/search" $ do
query <- param "q"
+ Scotty.setHeader "Access-Control-Allow-Origin" "*"
+ Scotty.setHeader "Content-Type" "application/json"
case tryParseType query of
Nothing -> Scotty.json $ A.object [ "error" .= ("Cannot parse type" :: Text) ]
Just ty -> do
- let ty' = replaceTypeVariablesAndDesugar ty
- let results = TS.typeSearch (Just []) initEnv (P.emptyCheckState initEnv) ty'
- Scotty.json $ A.object [ "results" .= A.object [ P.showQualified P.runIdent k .= P.prettyPrintType v
- | (k, v) <- take 20 (M.toList results)
- ]
+ let elabs = lookupAllConstructors initEnv ty
+ search = M.toList . TS.typeSearch (Just []) initEnv (P.emptyCheckState initEnv)
+ results = nubBy ((==) `on` fst) $ do
+ elab <- elabs
+ let strictMatches = search (replaceTypeVariablesAndDesugar (\nm s -> P.Skolem nm s (P.SkolemScope 0) Nothing) elab)
+ flexMatches = search (replaceTypeVariablesAndDesugar (const P.TUnknown) elab)
+ take 50 (strictMatches ++ flexMatches)
+ Scotty.json $ A.object [ "results" .= [ P.showQualified P.runIdent k
+ | (k, _) <- take 50 results
+ ]
]
+lookupAllConstructors :: P.Environment -> P.Type -> [P.Type]
+lookupAllConstructors env = P.everywhereOnTypesM $ \case
+ P.TypeConstructor (P.Qualified Nothing tyCon) -> P.TypeConstructor <$> lookupConstructor env tyCon
+ other -> pure other
+ where
+ lookupConstructor :: P.Environment -> P.ProperName 'P.TypeName -> [P.Qualified (P.ProperName 'P.TypeName)]
+ lookupConstructor env nm =
+ [ q
+ | (q@(P.Qualified (Just mn) thisNm), _) <- M.toList (P.types env)
+ , thisNm == nm
+ ]
+
-- | (Consistently) replace unqualified type constructors and type variables with unknowns.
--
-- Also remove the @ParensInType@ Constructor (we need to deal with type operators later at some point).
-replaceTypeVariablesAndDesugar :: P.Type -> P.Type
-replaceTypeVariablesAndDesugar ty = State.evalState (P.everywhereOnTypesM go ty) (0, M.empty) where
+replaceTypeVariablesAndDesugar :: (Text -> Int -> P.Type) -> P.Type -> P.Type
+replaceTypeVariablesAndDesugar f ty = State.evalState (P.everywhereOnTypesM go ty) (0, M.empty) where
go = \case
P.ParensInType ty -> pure ty
- P.TypeConstructor (P.Qualified Nothing tyCon) -> do
- (next, m) <- State.get
- case M.lookup (Left tyCon) m of
- Nothing -> do
- let ty = P.TUnknown next
- State.put (next + 1, M.insert (Left tyCon) ty m)
- pure ty
- Just ty -> pure ty
P.TypeVar s -> do
(next, m) <- State.get
- case M.lookup (Right s) m of
+ case M.lookup s m of
Nothing -> do
- let ty = P.TUnknown next
- State.put (next + 1, M.insert (Right s) ty m)
+ let ty = f s next
+ State.put (next + 1, M.insert s ty m)
pure ty
Just ty -> pure ty
other -> pure other