packages feed

psc-ide 0.3.0.0 → 0.5.0

raw patch · 17 files changed

+571/−346 lines, 17 filesdep +bytestringdep +purescript

Dependencies added: bytestring, purescript

Files

lib/PureScript/Ide.hs view
@@ -1,10 +1,11 @@+{-# LANGUAGE TupleSections #-} module PureScript.Ide where  import           Control.Monad.Except import           Control.Monad.State.Lazy (StateT (..), get, modify) import           Control.Monad.Trans.Either import qualified Data.Map.Lazy            as M-import           Data.Maybe               (mapMaybe)+import           Data.Maybe               (mapMaybe, catMaybes) import           Data.Monoid import qualified Data.Text  as T import           PureScript.Ide.Completion@@ -12,28 +13,66 @@ import           PureScript.Ide.Pursuit import           PureScript.Ide.Error import           PureScript.Ide.Types+import           PureScript.Ide.SourceFile+import           PureScript.Ide.Reexports import           System.FilePath import           System.Directory  type PscIde = StateT PscState IO +getPscIdeState :: PscIde (M.Map ModuleIdent [ExternDecl])+getPscIdeState = pscStateModules <$> get+ getAllDecls :: PscIde [ExternDecl]-getAllDecls = concat . pscStateModules <$> get+getAllDecls = concat <$> getPscIdeState  getAllModules :: PscIde [Module]-getAllModules = M.toList . pscStateModules <$> get+getAllModules = M.toList <$> getPscIdeState +getAllModulesWithReexports :: PscIde [Module]+getAllModulesWithReexports = do+  mis <- M.keys <$> getPscIdeState+  ms  <- traverse getModuleWithReexports mis+  return (catMaybes ms)++getModule :: ModuleIdent -> PscIde (Maybe Module)+getModule m = do+  modules <- getPscIdeState+  return ((m,) <$> M.lookup m modules)++getModuleWithReexports :: ModuleIdent -> PscIde (Maybe Module)+getModuleWithReexports mi = do+  m <- getModule mi+  db <- getPscIdeState+  case m of+    Just m' -> do+      resolved <- resolveReexports m' db+      return (Just resolved)+    Nothing -> return Nothing+  where+    resolveReexports m db = do+      let replaced = replaceReexports m db+      -- Maybe add logging for statements like these+      -- liftIO $ print (getReexports replaced)+      if null . getReexports $ replaced+        then return replaced+        else resolveReexports replaced db++insertModule :: Module -> PscIde ()+insertModule (name, decls) =+  modify (\x -> x { pscStateModules = M.insert name decls (pscStateModules x)})+ findCompletions :: [Filter] -> Matcher -> PscIde Success findCompletions filters matcher =-    CompletionResult <$> getCompletions filters matcher <$> getAllModules+  CompletionResult <$> getCompletions filters matcher <$> getAllModulesWithReexports  findType :: DeclIdent -> [Filter] -> PscIde Success findType search filters =-    CompletionResult <$> getExactMatches search filters <$> getAllModules+  CompletionResult <$> getExactMatches search filters <$> getAllModulesWithReexports  findPursuitCompletions :: PursuitQuery -> PscIde Success findPursuitCompletions (PursuitQuery q) =-    PursuitResult <$> liftIO (searchPursuitForDeclarations q)+  PursuitResult <$> liftIO (searchPursuitForDeclarations q)  findPursuitPackages :: PursuitQuery -> PscIde Success findPursuitPackages (PursuitQuery q) =@@ -41,75 +80,84 @@  loadExtern :: FilePath -> PscIde (Either Error ()) loadExtern fp = runEitherT $ do-    decls          <- EitherT . liftIO $ readExternFile fp-    (name, decls') <- EitherT . return $ moduleFromDecls decls-    modify (\x ->-              x-              { pscStateModules = M.insert-                                  name-                                  decls'-                                  (pscStateModules x)-              })--getDependenciesForModule :: ModuleIdent -> PscIde (Maybe [ModuleIdent])-getDependenciesForModule m = do-  mDecls <- M.lookup m . pscStateModules <$> get-  return $ mapMaybe getDependencyName <$> mDecls-  where getDependencyName (Dependency dependencyName _) = Just dependencyName-        getDependencyName _ = Nothing+  m <- EitherT . liftIO $ readExternFile fp+  lift (insertModule m) -moduleFromDecls :: [ExternDecl] -> Either Error Module-moduleFromDecls decls@(ModuleDecl name _:_) = Right (name, decls)-moduleFromDecls _ = Left (GeneralError "An externs File didn't start with a module declaration")+printModules :: PscIde Success+printModules = do+  modules <- M.keys <$> getPscIdeState+  return (ModuleList modules) -stateFromDecls :: [[ExternDecl]] -> Either Error PscState-stateFromDecls externs= do-  modules <- mapM moduleFromDecls externs-  return $ PscState (M.fromList modules)+listAvailableModules :: PscIde Success+listAvailableModules = liftIO $ do+  cwd <- getCurrentDirectory+  modules <- getDirectoryContents (cwd </> "output")+  let cleanedModules = filter (`notElem` [".", ".."]) modules+  return (ModuleList (map T.pack cleanedModules)) -printModules :: PscIde Success-printModules =-    TextResult . T.intercalate ", " . M.keys . pscStateModules <$> get+importsForFile :: FilePath -> PscIde (Either Error Success)+importsForFile fp = do+  imports <- liftIO (getImportsForFile fp)+  return (ImportList <$> imports)  -- | The first argument is a set of modules to load. The second argument --   denotes modules for which to load dependencies loadModulesAndDeps :: [ModuleIdent] -> [ModuleIdent] -> PscIde (Either Error Success) loadModulesAndDeps mods deps = do-    r1 <- mapM loadModule mods-    r2 <- mapM loadModuleDependencies deps-    return $-        TextResult <$>-        liftM2-            (\x y -> x <> ", " <> y)-            (T.concat <$> sequence r1)-            (T.concat <$> sequence r2)+  r1 <- mapM loadModule (mods ++ deps)+  r2 <- mapM loadModuleDependencies deps+  return $ do+    moduleResults <- fmap T.concat (sequence r1)+    dependencyResults <- fmap T.concat (sequence r2)+    return (TextResult (moduleResults <> ", " <> dependencyResults))  loadModuleDependencies :: ModuleIdent -> PscIde (Either Error T.Text) loadModuleDependencies moduleName = do-    _ <- loadModule moduleName-    mDeps <- getDependenciesForModule moduleName-    case mDeps of-        Just deps -> do-            mapM_ loadModule deps-            return (Right ("Dependencies for " <> moduleName <> " loaded."))-        Nothing -> return (Left (ModuleNotFound moduleName))+  m <- getModule moduleName+  case getDependenciesForModule <$> m of+    Just deps -> do+      mapM_ loadModule deps+      -- We need to load the modules, that get reexported from the dependencies+      depModules <- catMaybes <$> mapM getModule deps+      -- What to do with errors here? This basically means a reexported dependency+      -- doesn't exist in the output/ folder+      _ <- traverse loadReexports depModules+      return (Right ("Dependencies for " <> moduleName <> " loaded."))+    Nothing -> return (Left (ModuleNotFound moduleName)) +loadReexports :: Module -> PscIde (Either Error [ModuleIdent])+loadReexports m = case getReexports m of+  [] -> return (Right [])+  exportDeps -> runEitherT $ do+    -- I'm fine with this crashing on a failed pattern match.+    -- If this ever fails I'll need to look at GADTs+    let reexports = map (\(Export mn) -> mn) exportDeps+    -- liftIO $ print reexports+    _ <- traverse (EitherT . loadModule) reexports+    exportDepsModules <- lift $ catMaybes <$> traverse getModule reexports+    exportDepDeps <- traverse (EitherT . loadReexports) exportDepsModules+    return $ concat exportDepDeps++getDependenciesForModule :: Module -> [ModuleIdent]+getDependenciesForModule (_, decls) = mapMaybe getDependencyName decls+  where getDependencyName (Dependency dependencyName _) = Just dependencyName+        getDependencyName _ = Nothing+ loadModule :: ModuleIdent -> PscIde (Either Error T.Text)-loadModule mn = do-    path <- liftIO $ filePathFromModule mn-    case path of-        Right p -> loadExtern p >> return (Right $ "Loaded extern file at: " <> T.pack p)-        Left err -> return (Left err)+loadModule mn = runEitherT $ do+  path <- EitherT . liftIO $ filePathFromModule "json" mn+  EitherT (loadExtern path)+  return ("Loaded extern file at: " <> T.pack path) -filePathFromModule :: ModuleIdent -> IO (Either Error FilePath)-filePathFromModule moduleName = do-    cwd <- getCurrentDirectory-    let path = cwd </> "output" </> T.unpack moduleName </> "externs.purs"-    ex <- doesFileExist path-    return $-        if ex-            then Right path-            else Left (ModuleFileNotFound moduleName)+filePathFromModule :: String -> ModuleIdent -> IO (Either Error FilePath)+filePathFromModule extension moduleName = do+  cwd <- getCurrentDirectory+  let path = cwd </> "output" </> T.unpack moduleName </> "externs." ++ extension+  ex <- doesFileExist path+  return $+    if ex+    then Right path+    else Left (ModuleFileNotFound moduleName)  -- | Taken from Data.Either.Utils maybeToEither :: MonadError e m =>
lib/PureScript/Ide/CodecJSON.hs view
@@ -1,17 +1,9 @@ module PureScript.Ide.CodecJSON where -import PureScript.Ide.Externs (ExternDecl(..)) import Data.Aeson import Data.Text (Text()) import Data.Text.Lazy (toStrict, fromStrict) import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)--instance ToJSON ExternDecl where-  toJSON (FunctionDecl n t)        = object ["name" .= n, "type" .= t]-  toJSON (ModuleDecl   n t)        = object ["name" .= n, "type" .= t]-  toJSON (DataDecl     n t)        = object ["name" .= n, "type" .= t]-  toJSON (Dependency   n names)    = object ["module" .= n, "names" .= names]-  toJSON (FixityDeclaration f p n) = object ["name" .= n, "fixity" .= show f, "precedence" .= p]  encodeT :: (ToJSON a) => a -> Text encodeT = toStrict . decodeUtf8 . encode
lib/PureScript/Ide/Command.hs view
@@ -17,15 +17,30 @@                , completeMatcher :: Matcher}     | Pursuit { pursuitQuery      :: PursuitQuery               , pursuitSearchType :: PursuitSearchType}-    | List+    | List {listType :: ListType}     | Cwd     | Quit +data ListType = LoadedModules | Imports FilePath | AvailableModules++instance FromJSON ListType where+  parseJSON = withObject "ListType" $ \o -> do+    (listType' :: String) <- o .: "type"+    case listType' of+      "import" -> do+        fp <- o .: "file"+        return (Imports fp)+      "loadedModules" -> return LoadedModules+      "availableModules" -> return AvailableModules+      _ -> mzero+ instance FromJSON Command where   parseJSON = withObject "command" $ \o -> do     (command :: String) <- o .: "command"     case command of-      "list" -> return List+      "list" -> do+        listType' <- o .:? "params"+        return $ List (fromMaybe LoadedModules listType')       "cwd"  -> return Cwd       "quit" -> return Quit       "load" -> do@@ -42,7 +57,7 @@         params <- o .: "params"         filters <- params .:? "filters"         matcher <- params .:? "matcher"-        return $ Complete (fromMaybe [] filters) (fromMaybe (Matcher id) matcher)+        return $ Complete (fromMaybe [] filters) (fromMaybe mempty matcher)       "pursuit" -> do         params <- o .: "params"         query <- params .: "query"@@ -83,4 +98,4 @@       Just "helm" -> error "Helm matcher not implemented yet."       Just "distance" -> error "Distance matcher not implemented yet."       Just _ -> mzero-      Nothing -> return $ Matcher id+      Nothing -> return mempty
lib/PureScript/Ide/Completion.hs view
@@ -4,22 +4,20 @@  import           Data.Maybe            (mapMaybe) import           PureScript.Ide.Filter+import           PureScript.Ide.Matcher import           PureScript.Ide.Types  -- | Applies the CompletionFilters and the Matcher to the given Modules --   and sorts the found Completions according to the Matching Score getCompletions :: [Filter] -> Matcher -> [Module] -> [Completion]-getCompletions filters (Matcher matcher) modules =-    matcher $ completionsFromModules (applyFilters filters modules)+getCompletions filters matcher modules =+    runMatcher matcher $ completionsFromModules (applyFilters filters modules)  getExactMatches :: DeclIdent -> [Filter] -> [Module] -> [Completion] getExactMatches search filters modules =     completionsFromModules $     applyFilters (equalityFilter search : filters) modules -applyFilters :: [Filter] -> [Module] -> [Module]-applyFilters = foldl (\f (Filter g) -> f . g) id- completionsFromModules :: [Module] -> [Completion] completionsFromModules = foldMap completionFromModule     where@@ -29,5 +27,5 @@ completionFromDecl :: ModuleIdent -> ExternDecl -> Maybe Completion completionFromDecl mi (FunctionDecl name type') = Just (Completion (mi, name, type')) completionFromDecl mi (DataDecl name kind)      = Just (Completion (mi, name, kind))-completionFromDecl mi (ModuleDecl name _)       = Just (Completion ("module", name, "module"))-completionFromDecl mi _                         = Nothing+completionFromDecl _ (ModuleDecl name _)        = Just (Completion ("module", name, "module"))+completionFromDecl _ _                          = Nothing
lib/PureScript/Ide/Externs.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-}  module PureScript.Ide.Externs@@ -8,181 +10,69 @@     DeclIdent,     Type,     Fixity(..),-    readExternFile,-    parseExtern,-    parseExternDecl,-    typeParse+    readExternFile   ) where -import           Data.Char            (digitToInt)-import           Data.Text            (Text ())-import qualified Data.Text            as T-import qualified Data.Text.IO         as T-import           PureScript.Ide.Types-import           Text.Parsec-import           Text.Parsec.Text-import           PureScript.Ide.Error   (Error(..), first) --- | Parses an extern file into the ExternDecl format.-readExternFile :: FilePath -> IO (Either Error [ExternDecl])-readExternFile fp = readExtern . T.lines <$> T.readFile fp--readExtern :: [Text] -> Either Error [ExternDecl]-readExtern strs = mapM parseExtern clean-  where-    clean = removeComments strs--removeComments :: [Text] -> [Text]-removeComments = filter (not . T.isPrefixOf "--")--parseExtern :: Text -> Either Error ExternDecl-parseExtern = first (flip ParseError $ "") . parse parseExternDecl ""--parseExternDecl :: Parser ExternDecl-parseExternDecl =-    try parseDependency <|> try parseFixityDecl <|> try parseFunctionDecl <|>-    try parseDataDecl <|>-    try parseModuleDecl <|>-    try parseTypeDecl <|>-    try parseNewtypeDecl <|>-    return (ModuleDecl "" [])--parseDependency :: Parser ExternDecl-parseDependency =-    try parseQualifiedImport <|> try parseHidingImport <|> try parseSpecifyingImport-    <|> parseSimpleImport--parseSimpleImport :: Parser ExternDecl-parseSimpleImport = do-    string "import"-    module' <- identifier-    eof-    return $ Dependency module' []--parseSpecifyingImport :: Parser ExternDecl-parseSpecifyingImport = do-    string "import"-    module' <- identifier-    char '('-    names <- sepBy identifier (char ',')-    char ')'-    eof-    return $ Dependency module' names--parseHidingImport :: Parser ExternDecl-parseHidingImport = do-    string "import"-    module' <- identifier-    string "hiding"-    spaces-    char '('-    hiddenNames <- sepBy identifier (char ',')-    char ')'-    eof-    return $ Dependency module' []--parseQualifiedImport :: Parser ExternDecl-parseQualifiedImport = do-    string "import qualified"-    module' <- identifier-    string "as"-    qualifier <- identifier-    eof-    return $ Dependency module' []--parseFixityDecl :: Parser ExternDecl-parseFixityDecl = do-    fixity <- parseFixity-    spaces-    priority <- digitToInt <$> digit-    spaces-    symbol <- many1 anyChar-    eof-    return (FixityDeclaration fixity priority (T.pack symbol))--parseFixity :: Parser Fixity-parseFixity =-    (try (string "infixr") >> return Infixr) <|>-    (try (string "infixl") >> return Infixl) <|>-    (string "infix" >> return Infix)--parseFunctionDecl :: Parser ExternDecl-parseFunctionDecl = do-    string "foreign import"-    spaces-    (name, type') <- parseType-    eof-    return (FunctionDecl (T.pack name) (T.pack type'))--parseDataDecl :: Parser ExternDecl-parseDataDecl = parseDataDecl' <|> parseForeignDataDecl--parseDataDecl' :: Parser ExternDecl-parseDataDecl' = do-  string "data"-  ident <- identifier-  kind <- many anyChar-  return (DataDecl ident (T.pack kind))+import           Data.Maybe                  (mapMaybe)+import qualified Data.Text                   as T+import qualified Data.Text.IO                as T+import qualified Language.PureScript.Externs as PE+import qualified Language.PureScript.AST.Declarations as D+import qualified Language.PureScript.Names   as N+import qualified Language.PureScript.Pretty  as PP+import           PureScript.Ide.CodecJSON+import           PureScript.Ide.Error        (Error (..))+import           PureScript.Ide.Types -parseForeignDataDecl :: Parser ExternDecl-parseForeignDataDecl = do-  string "foreign import data"-  spaces-  (name, kind) <- parseType-  eof-  return $ DataDecl (T.pack name) (T.pack kind)+readExternFile :: FilePath -> IO (Either Error Module)+readExternFile fp = do+   (parseResult :: Maybe PE.ExternsFile) <- decodeT <$> T.readFile fp+   case parseResult of+     Nothing -> return . Left . GeneralError $ "Parsing the extern at: " ++ fp ++ " failed"+     Just externs -> return (Right (convertExterns externs)) -parseModuleDecl :: Parser ExternDecl-parseModuleDecl = do-  string "module"-  name <- identifier-  exports <- identifierList-  return (ModuleDecl name exports)+moduleNameToText :: N.ModuleName -> T.Text+moduleNameToText = T.pack . N.runModuleName -parseNewtypeDecl :: Parser ExternDecl-parseNewtypeDecl = do-  string "newtype"-  name <- identifier-  _ <- many (noneOf "=")-  char '='-  identifier-  type' <- many anyChar-  eof-  return (DataDecl name (T.pack type'))+properNameToText :: N.ProperName -> T.Text+properNameToText = T.pack . N.runProperName -parseTypeDecl :: Parser ExternDecl-parseTypeDecl = do-  string "type"-  name <- identifier-  _ <- many (noneOf "=")-  char '='-  spaces-  type' <- many anyChar-  eof-  return (DataDecl name (T.pack type'))+identToText :: N.Ident -> T.Text+identToText  = T.pack . N.runIdent -parseType :: Parser (String, String)-parseType = do-  name <- identifier-  string "::"-  spaces-  type' <- many1 anyChar-  return (T.unpack name, type')+convertExterns :: PE.ExternsFile -> Module+convertExterns ef = (moduleName, exportDecls ++ importDecls ++ otherDecls)+  where+    moduleName = moduleNameToText (PE.efModuleName ef)+    importDecls = convertImport <$> PE.efImports ef+    exportDecls = mapMaybe convertExport (PE.efExports ef)+    -- Ignoring operator fixities for now since we're not using them+    -- operatorDecls = convertOperator <$> PE.efFixities ef+    otherDecls = mapMaybe convertDecl (PE.efDeclarations ef) -typeParse :: Text -> Either Text (Text, Text)-typeParse t = case parse parseType "" t of-  Right (x,y) -> Right (T.pack x, T.pack y)-  Left err -> Left (T.pack (show err))+convertImport :: PE.ExternsImport -> ExternDecl+convertImport ei = Dependency (moduleNameToText (PE.eiModule ei)) [] -identifierList :: Parser [Text]-identifierList = between (char '(') (char ')') (sepBy identifier (char ','))+convertExport :: D.DeclarationRef -> Maybe ExternDecl+convertExport (D.ModuleRef mn) = Just (Export (T.pack $ N.runModuleName mn))+convertExport _ = Nothing -identifier :: Parser Text-identifier = do-    spaces-    ident <--        -- necessary for being able to parse the following ((++), concat)-        between (char '(') (char ')') (many1 (noneOf ", )")) <|>-        many1 (noneOf ", )")-    spaces-    return (T.pack ident)+convertDecl :: PE.ExternsDeclaration -> Maybe ExternDecl+convertDecl (PE.EDType{..}) = Just $+  DataDecl+  (properNameToText edTypeName)+  (T.pack (PP.prettyPrintKind edTypeKind))+convertDecl (PE.EDTypeSynonym{..}) = Just $+  DataDecl+  (properNameToText edTypeSynonymName)+  (T.pack (PP.prettyPrintType edTypeSynonymType))+convertDecl (PE.EDDataConstructor{..}) = Just $+  DataDecl+  (properNameToText edDataCtorName)+  (T.pack (PP.prettyPrintType edDataCtorType))+convertDecl (PE.EDValue{..}) = Just $+  FunctionDecl+  (identToText edValueName)+  (T.pack (PP.prettyPrintType edValueType))+convertDecl _ = Nothing
lib/PureScript/Ide/Filter.hs view
@@ -1,23 +1,28 @@ module PureScript.Ide.Filter        (moduleFilter, prefixFilter, equalityFilter, dependencyFilter,-        runFilter)+        runFilter, applyFilters)        where -import           Data.Maybe           (mapMaybe, listToMaybe)+import           Data.Foldable+import           Data.Maybe           (listToMaybe, mapMaybe)+import           Data.Monoid import           Data.Text            (Text, isPrefixOf) import           PureScript.Ide.Types +mkFilter :: ([Module] -> [Module]) -> Filter+mkFilter = Filter . Endo+ -- | Only keeps the given Modules moduleFilter :: [ModuleIdent] -> Filter moduleFilter =-    Filter . moduleFilter'+    mkFilter . moduleFilter'  moduleFilter' :: [ModuleIdent] -> [Module] -> [Module] moduleFilter' moduleIdents = filter (flip elem moduleIdents . fst)  -- | Only keeps the given Modules and all of their dependencies dependencyFilter :: [ModuleIdent] -> Filter-dependencyFilter = Filter . dependencyFilter'+dependencyFilter = mkFilter . dependencyFilter'  dependencyFilter' :: [ModuleIdent] -> [Module] -> [Module] dependencyFilter' moduleIdents mods =@@ -39,8 +44,8 @@  -- | Only keeps Identifiers that start with the given prefix prefixFilter :: Text -> Filter-prefixFilter "" = Filter id-prefixFilter t = Filter $ identFilter prefix t+prefixFilter "" = mkFilter id+prefixFilter t = mkFilter $ identFilter prefix t   where     prefix :: ExternDecl -> Text -> Bool     prefix (FunctionDecl name _) search = search `isPrefixOf` name@@ -51,7 +56,7 @@  -- | Only keeps Identifiers that are equal to the search string equalityFilter :: Text -> Filter-equalityFilter = Filter . identFilter equality+equalityFilter = mkFilter . identFilter equality   where     equality :: ExternDecl -> Text -> Bool     equality (FunctionDecl name _) prefix = prefix == name@@ -68,4 +73,7 @@         (moduleIdent, filter (`predicate` search) decls)  runFilter :: Filter -> [Module] -> [Module]-runFilter (Filter f) = f+runFilter (Filter f)= appEndo f++applyFilters :: [Filter] -> [Module] -> [Module]+applyFilters = runFilter . fold
lib/PureScript/Ide/Matcher.hs view
@@ -3,13 +3,14 @@ import           Data.Function        (on) import           Data.List            (sortBy) import           Data.Maybe           (mapMaybe)+import           Data.Monoid import qualified Data.Text            as T import qualified Data.Text.Encoding   as TE import           PureScript.Ide.Types import           Text.Regex.TDFA      ((=~))  -type ScoredCompletion = (Double, Completion)+type ScoredCompletion = (Completion, Double)  -- | Matches any occurence of the search string with intersections -- |@@ -22,21 +23,21 @@ flexMatcher pattern = mkMatcher (flexMatch pattern)  mkMatcher :: ([Completion] -> [ScoredCompletion]) -> Matcher-mkMatcher matcher = Matcher $ fmap snd . sortCompletions . matcher-+mkMatcher matcher = Matcher . Endo  $ fmap fst . sortCompletions . matcher  runMatcher :: Matcher -> [Completion] -> [Completion]-runMatcher (Matcher m) = m+runMatcher (Matcher m)= appEndo m  sortCompletions :: [ScoredCompletion] -> [ScoredCompletion]-sortCompletions = sortBy (flip compare `on` fst)+sortCompletions = sortBy (flip compare `on` snd)  flexMatch :: T.Text -> [Completion] -> [ScoredCompletion] flexMatch pattern = mapMaybe (flexRate pattern)  flexRate :: T.Text -> Completion -> Maybe ScoredCompletion-flexRate pattern c@(Completion (_,ident,_)) =-    (,) <$> flexScore pattern ident <*> pure c+flexRate pattern c@(Completion (_,ident,_)) = do+    score <- flexScore pattern ident+    return (c, score)  -- FlexMatching ala Sublime. -- Borrowed from: http://cdewaka.com/2013/06/fuzzy-pattern-matching-in-haskell/@@ -51,7 +52,9 @@         (-1,0) -> Nothing         (start,len) -> Just $ calcScore start (start + len)   where-    Just (first, pattern) = T.uncons pat+    Just (first,pattern) = T.uncons pat+    -- This just interleaves the search string with .*+    -- abcd -> a.*b.*c.*d     pat' = first `T.cons` T.concatMap (T.snoc ".*") pattern     calcScore start end =         100.0 / fromIntegral ((1 + start) * (end - start + 1))
lib/PureScript/Ide/Pursuit.hs view
@@ -3,19 +3,22 @@  module PureScript.Ide.Pursuit where -import qualified Control.Exception      as E-import           Control.Lens+import qualified Control.Exception    as E+import           Control.Lens         hiding (noneOf) import           Control.Monad import           Data.Aeson import           Data.Aeson.Lens+import           Data.ByteString.Lazy (ByteString) import           Data.Maybe-import           Data.Text              (Text)-import qualified Data.Text              as T-import           Network.HTTP.Client    (HttpException (StatusCodeException))+import           Data.Text            (Text)+import qualified Data.Text            as T+import           Network.HTTP.Client  (HttpException (StatusCodeException)) import           Network.Wreq-import           PureScript.Ide.Externs (typeParse) import           PureScript.Ide.Types +import           Text.Parsec+import           Text.Parsec.Text+ instance FromJSON PursuitResponse where     parseJSON (Object o) = do         package <- o .: "package"@@ -31,7 +34,7 @@                     }             "declaration" -> do                 moduleName <- info .: "module"-                Right (ident,declType) <- typeParse <$> o .: "text"+                Right (ident, declType) <- typeParse <$> o .: "text"                 return                     DeclarationResponse                     { declarationResponseType = declType@@ -51,6 +54,8 @@  -- We need to remove trailing dots because Pursuit will return a 400 otherwise -- TODO: remove this when the issue is fixed at Pursuit++queryPursuit :: Text -> IO (Response ByteString) queryPursuit q = getWith (jsonOpts (T.dropWhileEnd (== '.') q)) queryUrl  handler :: HttpException -> IO [a]@@ -76,3 +81,26 @@   where     isModuleResponse (Success a@(ModuleResponse{})) = Just a     isModuleResponse _ = Nothing++parseType :: Parser (String, String)+parseType = do+  name <- identifier+  _ <- string "::"+  spaces+  type' <- many1 anyChar+  return (T.unpack name, type')++typeParse :: Text -> Either Text (Text, Text)+typeParse t = case parse parseType "" t of+  Right (x,y) -> Right (T.pack x, T.pack y)+  Left err -> Left (T.pack (show err))++identifier :: Parser Text+identifier = do+  spaces+  ident <-+      -- necessary for being able to parse the following ((++), concat)+      between (char '(') (char ')') (many1 (noneOf ", )")) <|>+      many1 (noneOf ", )")+  spaces+  return (T.pack ident)
+ lib/PureScript/Ide/Reexports.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE TupleSections #-}+module PureScript.Ide.Reexports where++import Data.Maybe+import Data.Map (Map)+import qualified Data.Map as Map+import Data.List (union)+import PureScript.Ide.Types++getReexports :: Module -> [ExternDecl]+getReexports (mn, decls)= mapMaybe getExport decls+  where getExport e@(Export mn')+          | mn /= mn' = Just e+          | otherwise = Nothing+        getExport _ = Nothing++replaceReexport :: ExternDecl -> Module -> Module -> Module+replaceReexport e@(Export _) (m, decls) (_, newDecls) =+  (m, filter (/= e) decls `union` newDecls)+replaceReexport _ _ _ = error "Should only get Exports here."++emptyModule :: Module+emptyModule = ("Empty", [])++isExport :: ExternDecl -> Bool+isExport (Export _) = True+isExport _ = False++removeExportDecls :: Module -> Module+removeExportDecls = fmap (filter (not . isExport))++replaceReexports :: Module -> Map ModuleIdent [ExternDecl] -> Module+replaceReexports m db = result+  where reexports = getReexports m+        result = foldl go (removeExportDecls m) reexports++        go :: Module -> ExternDecl -> Module+        go m' re@(Export name) = replaceReexport re m' (getModule name)++        getModule :: ModuleIdent -> Module+        getModule name = clean res+          where res = fromMaybe emptyModule $ (name , ) <$> Map.lookup name db+                -- we have to do this because keeping self exports in will result in+                -- infinite loops+                clean (mn, decls) = (mn,) (filter (/= Export mn) decls)
+ lib/PureScript/Ide/SourceFile.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE FlexibleContexts #-}+module PureScript.Ide.SourceFile where++import           Data.Maybe                           (mapMaybe)+import           Data.Monoid+import qualified Data.Text                            as T+import qualified Language.PureScript.AST.Declarations as D+import qualified Language.PureScript.Parser           as P+import           PureScript.Ide.Error+import           PureScript.Ide.Types+import qualified Language.PureScript.AST.SourcePos    as SP+import qualified Language.PureScript.Names            as N+import           System.Directory++parseModuleFromFile :: FilePath -> IO (Either Error D.Module)+parseModuleFromFile fp = do+  exists <- doesFileExist fp+  if exists+    then do+      content <- readFile fp+      let m = do tokens <- P.lex fp content+                 P.runTokenParser "" P.parseModule tokens+      return (first (`ParseError` "File could not be parsed.") m)+    else return $ Left (NotFound "File does not exist.")++-- data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef])++getDeclarations :: D.Module -> [D.Declaration]+getDeclarations (D.Module _ _ _ declarations _) = declarations++getImports :: D.Module -> [D.Declaration]+getImports (D.Module _ _ _ declarations _) =+  mapMaybe isImport declarations+  where+    isImport (D.PositionedDeclaration _ _ (i@D.ImportDeclaration{})) = Just i+    isImport _ = Nothing++getImportsForFile :: FilePath -> IO (Either Error [ModuleImport])+getImportsForFile fp = do+  module' <- parseModuleFromFile fp+  let imports = getImports <$> module'+  return (fmap (mkModuleImport . unwrapPositionedImport) <$> imports)+  where mkModuleImport (D.ImportDeclaration mn importType' qualifier) =+          ModuleImport+            (T.pack (N.runModuleName mn))+            importType'+            (T.pack . N.runModuleName <$> qualifier)+        mkModuleImport _ = error "Shouldn't have gotten anything but Imports here"+        unwrapPositionedImport (D.ImportDeclaration mn importType' qualifier) =+          D.ImportDeclaration mn (unwrapImportType importType') qualifier+        unwrapPositionedImport x = x+        unwrapImportType (D.Explicit decls) = D.Explicit (map unwrapPositionedRef decls)+        unwrapImportType (D.Hiding decls)   = D.Hiding (map unwrapPositionedRef decls)+        unwrapImportType D.Implicit         = D.Implicit++getPositionedImports :: D.Module -> [D.Declaration]+getPositionedImports (D.Module _ _ _ declarations _) =+  mapMaybe isImport declarations+  where+    isImport i@(D.PositionedDeclaration _ _ (D.ImportDeclaration{})) = Just i+    isImport _ = Nothing++unwrapPositioned :: D.Declaration -> D.Declaration+unwrapPositioned (D.PositionedDeclaration _ _ x) = x+unwrapPositioned x = x++unwrapPositionedRef :: D.DeclarationRef -> D.DeclarationRef+unwrapPositionedRef (D.PositionedDeclarationRef _ _ x) = x+unwrapPositionedRef x = x++getDeclPosition :: D.Module -> String -> Maybe SP.SourceSpan+getDeclPosition m ident =+  let decls = getDeclarations m+  in getFirst (foldMap (match ident) decls)+     where match q (D.PositionedDeclaration ss _ decl) = First (if go q decl+                                                                then Just ss+                                                                else Nothing)+           match _ _ = First Nothing++           go q (D.DataDeclaration _ name _ constructors)  =+             properEqual name q || any (\(x,_) -> properEqual x q) constructors+           go q (D.DataBindingGroupDeclaration decls)      = any (go q) decls+           go q (D.TypeSynonymDeclaration name _ _)        = properEqual name q+           go q (D.TypeDeclaration ident' _)               = identEqual ident' q+           go q (D.ValueDeclaration ident' _ _ _)          = identEqual ident' q+           go q (D.ExternDeclaration ident' _)             = identEqual ident' q+           go q (D.ExternDataDeclaration name _)           = properEqual name q+           go q (D.TypeClassDeclaration name _ _ members)  =+             properEqual name q || any (go q . unwrapPositioned) members+           go q (D.TypeInstanceDeclaration ident' _ _ _ _) =+             identEqual ident' q+           go _ _ = False++           properEqual x q = N.runProperName x == q+           identEqual x q = N.runIdent x == q++goToDefinition :: String -> FilePath -> IO (Maybe SP.SourceSpan)+goToDefinition q fp = do+  m <- parseModuleFromFile fp+  case m of+    Right module' -> return $ getDeclPosition module' q+    Left _ -> return Nothing
lib/PureScript/Ide/Types.hs view
@@ -1,16 +1,22 @@-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards            #-}+ module PureScript.Ide.Types where  import           Control.Monad import           Data.Aeson-import           Data.Map.Lazy as M-import           Data.Text     (Text ())+import           Data.Map.Lazy                        as M+import           Data.Maybe                           (maybeToList)+import           Data.Monoid+import           Data.Text                            (Text ())+import qualified Language.PureScript.AST.Declarations as D+import qualified Language.PureScript.Names            as N  type ModuleIdent = Text type DeclIdent   = Text type Type        = Text -data Fixity = Infix | Infixl | Infixr deriving(Show, Eq)+data Fixity = Infix | Infixl | Infixr deriving(Show, Eq, Ord)  data ExternDecl     = FunctionDecl { functionName :: DeclIdent@@ -24,8 +30,19 @@                  [DeclIdent]     | DataDecl DeclIdent                Text-    deriving (Show,Eq)+    | Export ModuleIdent+    deriving (Show,Eq,Ord) +instance ToJSON ExternDecl where+  toJSON (FunctionDecl n t)        = object ["name" .= n, "type" .= t]+  toJSON (ModuleDecl   n t)        = object ["name" .= n, "type" .= t]+  toJSON (DataDecl     n t)        = object ["name" .= n, "type" .= t]+  toJSON (Dependency   n names)    = object ["module" .= n, "names" .= names]+  toJSON (FixityDeclaration f p n) = object ["name" .= n+                                            , "fixity" .= show f+                                            , "precedence" .= p]+  toJSON (Export _) = object []+ type Module = (ModuleIdent, [ExternDecl])  data PscState = PscState@@ -39,37 +56,68 @@     Completion (ModuleIdent, DeclIdent, Type)     deriving (Show,Eq) +data ModuleImport = ModuleImport {+  importModuleName :: ModuleIdent,+  importType       :: D.ImportDeclarationType,+  importQualifier  :: Maybe Text} deriving(Show)++instance Eq ModuleImport where+  mi1 == mi2 = importModuleName mi1 == importModuleName mi2+               && importQualifier mi1 == importQualifier mi2++instance ToJSON ModuleImport where+  toJSON (ModuleImport mn D.Implicit qualifier) =+    object $  ["module" .= mn+              , "importType" .= ("implicit" :: Text)+              ] ++ fmap (\x -> "qualifier" .= x) (maybeToList qualifier)+  toJSON (ModuleImport mn (D.Explicit refs) _) =+    object ["module" .= mn+           , "importType" .= ("explicit" :: Text)+           , "identifiers" .= (identifierFromDeclarationRef <$> refs)]+  toJSON (ModuleImport mn (D.Hiding refs) _) =+    object ["module" .= mn+           , "importType" .= ("hiding" :: Text)+           , "identifiers" .= (identifierFromDeclarationRef <$> refs)]++identifierFromDeclarationRef :: D.DeclarationRef -> String+identifierFromDeclarationRef (D.TypeRef name _) = N.runProperName name+identifierFromDeclarationRef (D.ValueRef ident) = N.runIdent ident+identifierFromDeclarationRef (D.TypeClassRef name) = N.runProperName name+identifierFromDeclarationRef _ = ""+ instance FromJSON Completion where-  parseJSON (Object o) = do-    m <- o .: "module"-    d <- o .: "identifier"-    t <- o .: "type"-    return $ Completion (m, d, t)-  parseJSON _ = mzero+    parseJSON (Object o) = do+        m <- o .: "module"+        d <- o .: "identifier"+        t <- o .: "type"+        return $ Completion (m, d, t)+    parseJSON _ = mzero  instance ToJSON Completion where-  toJSON (Completion (m, d, t)) =-    object ["module" .= m, "identifier" .= d, "type" .= t]+    toJSON (Completion (m,d,t)) =+        object ["module" .= m, "identifier" .= d, "type" .= t]  data Success =   CompletionResult [Completion]   | TextResult Text   | PursuitResult [PursuitResponse]-    deriving(Show, Eq)+  | ImportList [ModuleImport]+  | ModuleList [ModuleIdent]+  deriving(Show, Eq)  encodeSuccess :: (ToJSON a) => a -> Value-encodeSuccess res = object-                    [-                      "resultType" .= ("success" :: Text),-                      "result" .= res-                    ]+encodeSuccess res =+    object ["resultType" .= ("success" :: Text), "result" .= res]+ instance ToJSON Success where   toJSON (CompletionResult cs) = encodeSuccess cs   toJSON (TextResult t) = encodeSuccess t   toJSON (PursuitResult resp) = encodeSuccess resp+  toJSON (ImportList decls) = encodeSuccess decls+  toJSON (ModuleList modules) = encodeSuccess modules -newtype Filter  = Filter ([Module] -> [Module])-newtype Matcher = Matcher ([Completion] -> [Completion])+newtype Filter = Filter (Endo [Module]) deriving(Monoid)+newtype Matcher = Matcher (Endo [Completion]) deriving(Monoid)  newtype PursuitQuery = PursuitQuery Text                      deriving (Show, Eq)
psc-ide.cabal view
@@ -1,5 +1,5 @@ name:                psc-ide-version:             0.3.0.0+version:             0.5.0 synopsis:            Language support for the PureScript programming language description:         Please see README.md homepage:            http://github.com/kRITZCREEK/psc-ide@@ -24,9 +24,12 @@                        , PureScript.Ide.Matcher                        , PureScript.Ide.Filter                        , PureScript.Ide.Types+                       , PureScript.Ide.SourceFile+                       , PureScript.Ide.Reexports   default-language:      Haskell2010   build-depends:         aeson                        , base >= 4.7 && < 5+                       , bytestring                        , containers                        , directory                        , either@@ -36,6 +39,7 @@                        , lens-aeson                        , mtl                        , parsec+                       , purescript                        , regex-tdfa                        , text                        , wreq@@ -73,9 +77,12 @@   hs-source-dirs:      test   default-language:    Haskell2010   main-is:             Spec.hs-  other-modules:       PureScript.Ide.ExternsSpec+  other-modules:       PureScript.IdeSpec                      , PureScript.Ide.FilterSpec                      , PureScript.Ide.MatcherSpec+                     , PureScript.Ide.ReexportsSpec   build-depends:       base    >= 4.7 && < 5                      , psc-ide+                     , mtl                      , hspec+                     , containers
server/Main.hs view
@@ -75,13 +75,13 @@         case decodeT cmd of             Just cmd' -> do                 result <- handleCommand cmd'-                when debug $ liftIO $ T.putStrLn ("Answer was: " <> (T.pack . show $ result))+                when debug $ liftIO $ T.putStrLn ("Answer was: " <> (T.pack . show $ result)) >> hFlush stdout                 case result of                   -- What function can I use to clean this up?                   Right r  -> liftIO $ T.hPutStrLn h (encodeT r)                   Left err -> liftIO $ T.hPutStrLn h (encodeT err)             Nothing ->-                liftIO $ T.hPutStrLn h $ encodeT (GeneralError "Error parsing Command.")+                liftIO $ T.hPutStrLn h (encodeT (GeneralError "Error parsing Command.")) >> hFlush stdout         liftIO $ hClose h  handleCommand :: Command -> PscIde (Either Error Success)@@ -95,9 +95,12 @@     Right <$> findPursuitPackages query handleCommand (Pursuit query Identifier) =     Right <$> findPursuitCompletions query-handleCommand List =+handleCommand (List LoadedModules) =     Right <$> printModules+handleCommand (List AvailableModules) =+    Right <$> listAvailableModules+handleCommand (List (Imports fp)) =+    importsForFile fp handleCommand Cwd =     Right . TextResult . T.pack <$> liftIO getCurrentDirectory handleCommand Quit = Right <$> liftIO exitSuccess-
src/Main.hs view
@@ -28,10 +28,10 @@ client port = do     h <-         connectTo "localhost" port `catch`-        (\(SomeException _) ->+        (\(SomeException e) ->               putStrLn                   ("Couldn't connect to psc-ide-server on port: " ++-                   show port) >>+                   show port ++ " Error: " ++ show e) >>               exitFailure)     cmd <- T.getLine     T.hPutStrLn h cmd@@ -39,3 +39,4 @@     putStrLn (T.unpack res)     hFlush stdout     hClose h+
− test/PureScript/Ide/ExternsSpec.hs 
@@ -1,46 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module PureScript.Ide.ExternsSpec where--import           PureScript.Ide.Externs-import           Test.Hspec--spec :: Spec-spec = do-    describe "Parsing imports" $ do-        it "parses a simple import statement" $-            parseExtern "import Data.Array" `shouldBe`-              Right (Dependency "Data.Array" [])-        it "parses a simple import statement" $-            parseExtern "import Data.Text (functionName, (++))" `shouldBe`-              Right (Dependency "Data.Text" ["functionName", "++"])-        it "parses a hiding import statement" $-            parseExtern "import Prelude hiding (wasd)" `shouldBe`-              Right (Dependency "Prelude" [])-        it "parses a qualified import statement" $-            parseExtern "import qualified Data.Text as T" `shouldBe`-              Right (Dependency "Data.Text" [])-    describe "Parsing modules" $-        it "parses a module declaration" $-            parseExtern "module My.Module (exportedFunction) where" `shouldBe`-              Right (ModuleDecl "My.Module" ["exportedFunction"])-    describe "Parsing functions" $-        it "parses a function declaration" $-            parseExtern "foreign import text :: forall eff s t. Prim.String -> SYM.Component eff s t"-              `shouldBe` Right (FunctionDecl "text" "forall eff s t. Prim.String -> SYM.Component eff s t")-    describe "Parsing Data Declaration" $ do-        it "parses a data declaration" $-            parseExtern "data Handler (eff :: # !) (s :: *)" `shouldBe`-              Right (DataDecl "Handler" "(eff :: # !) (s :: *)")-        it "parses a foreign data declaration" $-            parseExtern "foreign import data STArray :: * -> * -> *" `shouldBe`-              Right (DataDecl "STArray" "* -> * -> *")-    describe "Parsing type declarations" $ do-        it "parses a newtype declaration" $-            parseExtern "newtype Component (eff :: # !) (s :: *) (t :: *) = Component (s -> SYM.Handler eff t -> Prim.Array React.ReactElement)" `shouldBe`-              Right (DataDecl "Component" "(s -> SYM.Handler eff t -> Prim.Array React.ReactElement)")-        it "parses a type declaration" $-            parseExtern "type Player = { age :: Prim.Number, name :: Prim.String }" `shouldBe`-              Right (DataDecl "Player" "{ age :: Prim.Number, name :: Prim.String }")--
+ test/PureScript/Ide/ReexportsSpec.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE OverloadedStrings #-}+module PureScript.Ide.ReexportsSpec where++import Test.Hspec+import PureScript.Ide.Reexports+import PureScript.Ide.Types+import Data.List (sort)+import qualified Data.Map as Map+import Control.Exception (evaluate)++decl1 = FunctionDecl "filter" "asdasd"+decl2 = DataDecl "Tree" "* -> *"+decl3 = DataDecl "TreeAsd" "* -> *"++circularModule = ("Circular", [Export "Circular"])++module1 :: Module+module1 = ("Module1", [Export "Module2", Export "Module3", decl1])++module2 :: Module+module2 = ("Module2", [decl2])++module3 :: Module+module3 = ("Module3", [decl3])++result :: Module+result = ("Module1", [decl1, decl2, Export "Module3"])++db = Map.fromList [module1, module2, module3]++shouldBeEqualSorted :: Module -> Module -> Expectation+shouldBeEqualSorted (n1, d1) (n2, d2) = (n1, sort d1) `shouldBe` (n2, sort d2)++spec = do+  describe "Reexports" $ do+    it "finds all reexports" $+      getReexports module1 `shouldBe` [Export "Module2", Export "Module3"]++    it "replaces a reexport with another module" $+      replaceReexport (Export "Module2") module1 module2 `shouldBeEqualSorted` result++    it "adds another module even if there is no export statement" $+      replaceReexport (Export "Module2") ("Module1", [decl1, Export "Module3"]) module2+      `shouldBeEqualSorted` result++    it "only adds a declaration once" $+      let replaced = replaceReexport (Export "Module2") module1 module2+      in replaceReexport (Export "Module2") replaced module2  `shouldBeEqualSorted` result++    it "should error when given a non-Export to replace" $+      evaluate (replaceReexport decl1 module1 module2) `shouldThrow` errorCall "Should only get Exports here."+    it "replaces all Exports with their corresponding declarations" $+      replaceReexports module1 db `shouldBe` ("Module1", [decl1, decl2, decl3])++    it "does not list itself as a reexport" $+      getReexports circularModule `shouldBe` []++    it "does not include circular references when replacing reexports" $+      replaceReexports circularModule (uncurry Map.singleton circularModule )+      `shouldBe` ("Circular", [])
+ test/PureScript/IdeSpec.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}+module PureScript.IdeSpec where++import           Control.Monad.State+import           Data.List+import qualified Data.Map             as Map+import           PureScript.Ide+import           PureScript.Ide.Types+import           Test.Hspec++testState :: PscState+testState = PscState (Map.fromList [("Data.Array", []), ("Control.Monad.Eff", [])])++spec :: SpecWith ()+spec = do+  describe "list" $ do+    describe "loadedModules" $ do+      it "returns an empty list when no modules are loaded" $ do+       result <- evalStateT printModules emptyPscState+       result `shouldBe` ModuleList []+      it "returns the list of loaded modules" $ do+        ModuleList result <- evalStateT printModules testState+        sort result `shouldBe` sort ["Data.Array", "Control.Monad.Eff"]