purescript 0.8.3.0 → 0.8.4.0

raw patch · 52 files changed

+2158/−523 lines, 52 filesdep ~language-javascriptdep ~utf8-string

Dependency ranges changed: language-javascript, utf8-string

Files

CONTRIBUTORS.md +2/−0
examples/docs/src/ConstrainedArgument.purs +9/−0
examples/failing/Generalization1.purs +11/−0
examples/failing/Generalization2.purs +8/−0
examples/passing/1991.purs +20/−0
examples/passing/Generalization1.purs +10/−0
psc-bundle/Main.hs +5/−16
psc-docs/Main.hs +5/−15
psc-ide-server/Main.hs +16/−1
psc-publish/Main.hs +6/−1
psc/Main.hs +5/−16
purescript.cabal +20/−6
src/Language/PureScript/AST/Traversals.hs +1/−1
src/Language/PureScript/Bundle.hs +240/−188
src/Language/PureScript/Docs/AsMarkdown.hs +1/−0
src/Language/PureScript/Docs/RenderedCode/Render.hs +24/−12
src/Language/PureScript/Errors.hs +31/−6
src/Language/PureScript/Ide.hs +63/−21
src/Language/PureScript/Ide/CaseSplit.hs +46/−37
src/Language/PureScript/Ide/CodecJSON.hs +0/−13
src/Language/PureScript/Ide/Command.hs +72/−20
src/Language/PureScript/Ide/Completion.hs +7/−10
src/Language/PureScript/Ide/Error.hs +15/−6
src/Language/PureScript/Ide/Externs.hs +58/−46
src/Language/PureScript/Ide/Filter.hs +28/−11
src/Language/PureScript/Ide/Imports.hs +355/−0
src/Language/PureScript/Ide/Matcher.hs +46/−25
src/Language/PureScript/Ide/Pursuit.hs +14/−0
src/Language/PureScript/Ide/Reexports.hs +16/−0
src/Language/PureScript/Ide/SourceFile.hs +16/−1
src/Language/PureScript/Ide/State.hs +21/−6
src/Language/PureScript/Ide/Types.hs +46/−48
src/Language/PureScript/Ide/Util.hs +65/−0
src/Language/PureScript/Ide/Watcher.hs +15/−0
src/Language/PureScript/Make.hs +57/−4
src/Language/PureScript/Parser/JS.hs +1/−1
src/Language/PureScript/TypeChecker.hs +2/−2
src/Language/PureScript/TypeChecker/Types.hs +27/−9
stack-lts-5.yaml +1/−0
stack-nightly.yaml +2/−1
stack.yaml +1/−0
tests/Language/PureScript/Ide/FilterSpec.hs +63/−0
tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs +101/−0
tests/Language/PureScript/Ide/ImportsSpec.hs +125/−0
tests/Language/PureScript/Ide/Integration.hs +238/−0
tests/Language/PureScript/Ide/MatcherSpec.hs +56/−0
tests/Language/PureScript/Ide/ReexportsSpec.hs +78/−0
tests/Language/PureScript/IdeSpec.hs +35/−0
tests/TestDocs.hs +30/−0
tests/support/pscide/src/ImportsSpec.purs +5/−0
tests/support/pscide/src/ImportsSpec1.purs +32/−0
tests/support/pscide/src/Main.purs +7/−0

CONTRIBUTORS.md view

@@ -68,6 +68,8 @@ - [@utkarshkukreti](https://github.com/utkarshkukreti) (Utkarsh Kukreti) My existing contributions and all future contributions until further notice are Copyright Utkarsh Kukreti, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@vkorablin](https://github.com/vkorablin) (Vladimir Korablin) - My existing contributions and all future contributions until further notice are Copyright Vladimir Korablin, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).+- [@LiamGoodacre](https://github.com/LiamGoodacre) (Liam Goodacre) My existing contributions and all future contributions until further notice are Copyright Liam Goodacre, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).+- [@bsermons](https://github.com/bsermons) (Brian Sermons) My existing contributions and all future contributions until further notice are Copyright Brian Sermons, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).  ### Companies

+ examples/docs/src/ConstrainedArgument.purs view

@@ -0,0 +1,9 @@+module ConstrainedArgument where++class Foo t++type WithoutArgs      = forall a. (Partial => a) -> a+type WithArgs         = forall a. (Foo a => a) -> a+type MultiWithoutArgs = forall a. ((Partial, Partial) => a) -> a+type MultiWithArgs    = forall a b. ((Foo a, Foo b) => a) -> a+

+ examples/failing/Generalization1.purs view

@@ -0,0 +1,11 @@+-- @shouldFailWith CannotGeneralizeRecursiveFunction+module Main where++import Prelude++foo 0 x _ = x+foo n x y = x <> bar (n - 1) x y++bar 0 x _ = x+bar n x y = y <> foo (n - 1) x y+

+ examples/failing/Generalization2.purs view

@@ -0,0 +1,8 @@+-- @shouldFailWith CannotGeneralizeRecursiveFunction+module Main where++import Prelude++test n m | n <= 1 = m+         | otherwise = test (n - 1) (m <> m)+

+ examples/passing/1991.purs view

@@ -0,0 +1,20 @@+module Main where++import Prelude++singleton :: forall a. a -> Array a+singleton x = [x]++empty :: forall a. Array a+empty = []++foldMap :: forall a m. (Semigroup m) => (a -> m) -> Array a -> m+foldMap f [a, b, c, d, e] = f a <> f b <> f c <> f d <> f e++regression :: Array Int+regression =+  let as = [1,2,3,4,5]+      as' = foldMap (\x -> if 1 < x && x < 4 then singleton x else empty) as+  in as'+                  +main = Control.Monad.Eff.Console.log "Done"

+ examples/passing/Generalization1.purs view

@@ -0,0 +1,10 @@+module Main where++import Prelude+import Control.Monad.Eff.Console (print)++main = do+  print (sum 1.0 2.0)+  print (sum 1 2)++sum x y = x + y

psc-bundle/Main.hs view

@@ -1,25 +1,12 @@------------------------------------------------------------------------------------ Module      :  psc-bundle--- Copyright   :  (c) Phil Freeman 2015--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ | Bundles compiled PureScript modules for the browser.---------------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RecordWildCards #-} +-- | Bundles compiled PureScript modules for the browser. module Main (main) where -import Data.Maybe +import Data.Maybe import Data.Traversable (for) import Data.Version (showVersion) @@ -32,7 +19,7 @@ import System.FilePath (takeFileName, takeDirectory) import System.FilePath.Glob (glob) import System.Exit (exitFailure)-import System.IO (stderr, hPutStrLn)+import System.IO (stderr, stdout, hPutStrLn, hSetEncoding, utf8) import System.Directory (createDirectoryIfMissing)  import Language.PureScript.Bundle@@ -125,6 +112,8 @@ -- | Make it go. main :: IO () main = do+  hSetEncoding stdout utf8+  hSetEncoding stderr utf8   opts <- execParser (info (version <*> helper <*> options) infoModList)   when (isJust (optionsRequirePath opts)) $ hPutStrLn stderr "The require-path option is deprecated and will be removed in PureScript 0.9."   output <- runExceptT (app opts)

psc-docs/Main.hs view

@@ -1,17 +1,4 @@ {-# LANGUAGE TupleSections #-}----------------------------------------------------------------------------------- Module      :  Main--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |---------------------------------------------------------------------------------  module Main where @@ -32,7 +19,7 @@ import qualified Language.PureScript as P import qualified Paths_purescript as Paths import System.Exit (exitFailure)-import System.IO (hPutStrLn, hPrint, stderr)+import System.IO (hPutStrLn, hPrint, hSetEncoding, stderr, stdout, utf8) import System.Directory (createDirectoryIfMissing) import System.FilePath (takeDirectory) import System.FilePath.Glob (glob)@@ -228,7 +215,10 @@       exitFailure  main :: IO ()-main = execParser opts >>= buildOptions >>= docgen+main = do+  hSetEncoding stdout utf8+  hSetEncoding stderr utf8+  execParser opts >>= buildOptions >>= docgen   where   opts        = info (version <*> helper <*> pscDocsOptions) infoModList   infoModList = fullDesc <> headerInfo <> footerInfo

psc-ide-server/Main.hs view

@@ -1,9 +1,24 @@+-----------------------------------------------------------------------------+--+-- Module      : Main+-- Description : The server accepting commands for psc-ide+-- Copyright   : Christoph Hegemann 2016+-- License     : MIT (http://opensource.org/licenses/MIT)+--+-- Maintainer  : Christoph Hegemann <christoph.hegemann1337@gmail.com>+-- Stability   : experimental+--+-- |+-- The server accepting commands for psc-ide+-----------------------------------------------------------------------------+ {-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE PackageImports        #-} {-# LANGUAGE TemplateHaskell       #-}+ module Main where  import           Prelude                           ()@@ -21,7 +36,7 @@ import qualified Data.Text.IO                      as T import           Data.Version                      (showVersion) import           Language.PureScript.Ide-import           Language.PureScript.Ide.CodecJSON+import           Language.PureScript.Ide.Util import           Language.PureScript.Ide.Error import           Language.PureScript.Ide.Types import           Language.PureScript.Ide.Watcher

psc-publish/Main.hs view

@@ -7,6 +7,8 @@  import Options.Applicative hiding (str) +import System.IO (hSetEncoding, stderr, stdout, utf8)+ import qualified Paths_purescript as Paths import Language.PureScript.Publish import Language.PureScript.Publish.ErrorsWarnings@@ -24,7 +26,10 @@   where dummyVersion = ("0.0.0", Version [0,0,0] [])  main :: IO ()-main = execParser opts >>= publish+main = do+  hSetEncoding stdout utf8+  hSetEncoding stderr utf8+  execParser opts >>= publish   where   opts        = info (version <*> helper <*> dryRun) infoModList   infoModList = fullDesc <> headerInfo <> footerInfo

psc/Main.hs view

@@ -1,17 +1,3 @@------------------------------------------------------------------------------------ Module      :  Main--- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess--- License     :  MIT (http://opensource.org/licenses/MIT)------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |---------------------------------------------------------------------------------- {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-}@@ -34,7 +20,7 @@ import Options.Applicative as Opts  import System.Exit (exitSuccess, exitFailure)-import System.IO (hPutStrLn, stderr)+import System.IO (hSetEncoding, hPutStrLn, stdout, stderr, utf8) import System.IO.UTF8 import System.FilePath.Glob (glob) @@ -202,7 +188,10 @@                                 <*> jsonErrors  main :: IO ()-main = execParser opts >>= compile+main = do+  hSetEncoding stdout utf8+  hSetEncoding stderr utf8+  execParser opts >>= compile   where   opts        = info (version <*> helper <*> pscMakeOptions) infoModList   infoModList = fullDesc <> headerInfo <> footerInfo

purescript.cabal view

@@ -1,5 +1,5 @@ name: purescript-version: 0.8.3.0+version: 0.8.4.0 cabal-version: >=1.8 build-type: Simple license: MIT@@ -36,6 +36,7 @@                   , tests/support/flattened/*.purs                   , tests/support/flattened/*.js                   , tests/support/psci/*.purs+                  , tests/support/pscide/src/*.purs                   , stack.yaml                   , stack-lts-5.yaml                   , stack-nightly.yaml@@ -74,7 +75,7 @@                    bytestring -any,                    text -any,                    split -any,-                   language-javascript == 0.5.*,+                   language-javascript == 0.6.*,                    syb -any,                    Glob >= 0.7 && < 0.8,                    process >= 1.2.0 && < 1.5,@@ -201,7 +202,6 @@                      Language.PureScript.Ide.Command                      Language.PureScript.Ide.Externs                      Language.PureScript.Ide.Error-                     Language.PureScript.Ide.CodecJSON                      Language.PureScript.Ide.Pursuit                      Language.PureScript.Ide.Completion                      Language.PureScript.Ide.Matcher@@ -212,6 +212,8 @@                      Language.PureScript.Ide.SourceFile                      Language.PureScript.Ide.Watcher                      Language.PureScript.Ide.Reexports+                     Language.PureScript.Ide.Imports+                     Language.PureScript.Ide.Util                       Control.Monad.Logger                      Control.Monad.Supply@@ -313,7 +315,7 @@  executable psc-ide-server   main-is:             Main.hs-  other-modules:+  other-modules:       Paths_purescript   other-extensions:   build-depends:       base >=4 && <5                      , purescript -any@@ -333,7 +335,7 @@  executable psc-ide-client   main-is:             Main.hs-  other-modules:+  other-modules:       Paths_purescript   other-extensions:   build-depends:       base >=4 && <5                      , mtl -any@@ -350,7 +352,8 @@                    transformers -any, process -any, transformers-compat -any, time -any,                    Glob -any, aeson-better-errors -any, bytestring -any, aeson -any,                    base-compat -any, haskeline >= 0.7.0.0, optparse-applicative -any,-                   boxes -any, HUnit -any, hspec -any, hspec-discover -any, stm -any, text -any+                   boxes -any, HUnit -any, hspec -any, hspec-discover -any, stm -any, text -any,+                   vector -any, utf8-string -any     ghc-options: -Wall     type: exitcode-stdio-1.0     main-is: Main.hs@@ -361,5 +364,16 @@                    TestPsci                    TestPscIde                    PscIdeSpec+                   Language.PureScript.Ide.FilterSpec+                   Language.PureScript.Ide.ImportsSpec+                   Language.PureScript.Ide.Imports.IntegrationSpec+                   Language.PureScript.Ide.Integration+                   Language.PureScript.Ide.MatcherSpec+                   Language.PureScript.Ide.ReexportsSpec+                   Language.PureScript.IdeSpec+                   PSCi.Completion+                   PSCi.Directive+                   PSCi.Module+                   PSCi.Types     buildable: True     hs-source-dirs: tests psci

src/Language/PureScript/AST/Traversals.hs view

@@ -508,7 +508,7 @@   g' :: S.Set Ident -> Expr -> r   g' s (Literal l) = lit g'' s l   g' s (UnaryMinus v1) = g'' s v1-  g' s (BinaryNoParens op v1 v2) = g' s op <> g' s v1 <> g' s v2+  g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2   g' s (Parens v1) = g'' s v1   g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v   g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v

src/Language/PureScript/Bundle.hs view

@@ -27,6 +27,7 @@    , ModuleType(..)    , ErrorMessage(..)    , printErrorMessage+   , getExportedIdentifiers ) where  import Prelude ()@@ -43,6 +44,7 @@ import Control.Monad import Control.Monad.Error.Class import Language.JavaScript.Parser+import Language.JavaScript.Parser.AST  import qualified Paths_purescript as Paths @@ -83,7 +85,7 @@ data ExportType   = RegularExport String   | ForeignReexport-  deriving (Show, Read, Eq, Ord)+  deriving (Show, Eq, Ord)  -- | There are four types of module element we are interested in: --@@ -95,14 +97,14 @@ -- Each is labelled with the original AST node which generated it, so that we can dump it back -- into the output during codegen. data ModuleElement-  = Require JSNode String (Either String ModuleIdentifier)-  | Member JSNode Bool String [JSNode] [Key]-  | ExportsList [(ExportType, String, JSNode, [Key])]-  | Other JSNode-  deriving (Show, Read)+  = Require JSStatement String (Either String ModuleIdentifier)+  | Member JSStatement Bool String JSExpression [Key]+  | ExportsList [(ExportType, String, JSExpression, [Key])]+  | Other JSStatement+  deriving (Show)  -- | A module is just a list of elements of the types listed above.-data Module = Module ModuleIdentifier [ModuleElement] deriving (Show, Read)+data Module = Module ModuleIdentifier [ModuleElement] deriving (Show)  -- | Prepare an error message for consumption by humans. printErrorMessage :: ErrorMessage -> [String]@@ -131,11 +133,6 @@   displayIdentifier (ModuleIdentifier name ty) =     name ++ " (" ++ showModuleType ty ++ ")" --- | Unpack the node inside a JSNode. This is useful when pattern matching.-node :: JSNode -> Node-node (NN n) = n-node (NT n _ _) = n- -- | Calculate the ModuleIdentifier which a require(...) statement imports. checkImportPath :: Maybe FilePath -> String -> ModuleIdentifier -> S.Set String -> Either String ModuleIdentifier checkImportPath _ "./foreign" m _ =@@ -179,116 +176,184 @@    -- | Calculate dependencies and add them to the current element.   expandDeps :: ModuleElement -> ModuleElement-  expandDeps (Member n f nm decl _) = Member n f nm decl (nub (concatMap (dependencies modulePath) decl))+  expandDeps (Member n f nm decl _) = Member n f nm decl (nub $ dependencies modulePath decl)   expandDeps (ExportsList exps) = ExportsList (map expand exps)       where       expand (ty, nm, n1, _) = (ty, nm, n1, nub (dependencies modulePath n1))   expandDeps other = other -  dependencies :: ModuleIdentifier -> JSNode -> [(ModuleIdentifier, String)]+  dependencies :: ModuleIdentifier -> JSExpression -> [(ModuleIdentifier, String)]   dependencies m = everything (++) (mkQ [] toReference)     where-    toReference :: Node -> [(ModuleIdentifier, String)]-    toReference (JSMemberDot [ mn ] _ nm)-      | JSIdentifier mn' <- node mn-      , JSIdentifier nm' <- node nm+    toReference :: JSExpression -> [(ModuleIdentifier, String)]+    toReference (JSMemberDot mn _ nm)+      | JSIdentifier _ mn' <- mn+      , JSIdentifier _ nm' <- nm       , Just mid <- lookup mn' imports       = [(mid, nm')]-    toReference (JSMemberSquare [ mn ] _ nm _)-      | JSIdentifier mn' <- node mn-      , JSExpression [ s ] <- node nm-      , JSStringLiteral _ nm' <- node s+    toReference (JSMemberSquare mn _ nm _)+      | JSIdentifier _ mn' <- mn+      , Just nm' <- fromStringLiteral nm       , Just mid <- lookup mn' imports       = [(mid, nm')]-    toReference (JSIdentifier nm)+    toReference (JSIdentifier _ nm)       | nm `elem` boundNames       = [(m, nm)]     toReference _ = [] +-- String literals include the quote chars+fromStringLiteral :: JSExpression -> Maybe String+fromStringLiteral (JSStringLiteral _ str) = Just $ trimStringQuotes str+fromStringLiteral _ = Nothing++trimStringQuotes :: String -> String+trimStringQuotes str = reverse $ drop 1 $ reverse $ drop 1 $ str++commaList :: JSCommaList a -> [a]+commaList JSLNil = []+commaList (JSLOne x) = [x]+commaList (JSLCons l _ x) = commaList l ++ [x]++trailingCommaList :: JSCommaTrailingList a -> [a]+trailingCommaList (JSCTLComma l _) = commaList l+trailingCommaList (JSCTLNone l) = commaList l+ -- | Attempt to create a Module from a Javascript AST. -- -- Each type of module element is matched using pattern guards, and everything else is bundled into the -- Other constructor.-toModule :: forall m. (MonadError ErrorMessage m) => Maybe FilePath -> S.Set String -> ModuleIdentifier -> JSNode -> m Module+toModule :: forall m. (MonadError ErrorMessage m) => Maybe FilePath -> S.Set String -> ModuleIdentifier -> JSAST -> m Module toModule requirePath mids mid top-  | JSSourceElementsTop ns <- node top = Module mid <$> traverse toModuleElement ns+  | JSAstProgram smts _ <- top = Module mid <$> traverse toModuleElement smts   | otherwise = err InvalidTopLevel   where   err = throwError . ErrorInModule mid -  toModuleElement :: JSNode -> m ModuleElement-  toModuleElement n-    | JSVariables var [ varIntro ] _ <- node n-    , JSLiteral "var" <- node var-    , JSVarDecl impN [ eq, req, impP ] <- node varIntro-    , JSIdentifier importName <- node impN-    , JSLiteral "=" <- node eq-    , JSIdentifier "require" <- node req-    , JSArguments _ [ impS ] _ <- node impP-    , JSStringLiteral _ importPath <- node impS-    , importPath' <- checkImportPath requirePath importPath mid mids-    = pure (Require n importName importPath')-  toModuleElement n-    | JSVariables var [ varIntro ] _ <- node n-    , JSLiteral "var" <- node var-    , JSVarDecl declN (eq : decl) <- node varIntro-    , JSIdentifier name <- node declN-    , JSLiteral "=" <- node eq-    = pure (Member n False name decl [])-  toModuleElement n-    | JSExpression (e : op : decl) <- node n-    , Just name <- accessor (node e)-    , JSOperator eq <- node op-    , JSLiteral "=" <- node eq-    = pure (Member n True name decl [])-    where-    accessor :: Node -> Maybe String-    accessor (JSMemberDot [ exports ] _ nm)-      | JSIdentifier "exports" <- node exports-      , JSIdentifier name <- node nm-      = Just name-    accessor (JSMemberSquare [ exports ] _ nm _)-      | JSIdentifier "exports" <- node exports-      , JSExpression [e] <- node nm-      , JSStringLiteral _ name <- node e-      = Just name-    accessor _ = Nothing-  toModuleElement n-    | JSExpression (mnExp : op : obj: _) <- node n-    , JSMemberDot [ mn ] _ e <- node mnExp-    , JSIdentifier "module" <- node mn-    , JSIdentifier "exports" <- node e-    , JSOperator eq <- node op-    , JSLiteral "=" <- node eq-    , JSObjectLiteral _ props _ <- node obj-    = ExportsList <$> traverse toExport (filter (not . isSeparator) (map node props))+  toModuleElement :: JSStatement -> m ModuleElement+  toModuleElement stmt+    | Just (importName, importPath) <- matchRequire requirePath mids mid stmt+    = pure (Require stmt importName importPath)+  toModuleElement stmt+    | Just (exported, name, decl) <- matchMember stmt+    = pure (Member stmt exported name decl [])+  toModuleElement stmt+    | Just props <- matchExportsAssignment stmt+    = (ExportsList <$> traverse toExport (trailingCommaList props))     where-    toExport :: Node -> m (ExportType, String, JSNode, [Key])-    toExport (JSPropertyNameandValue name _ [val] ) =-      (,,val,[]) <$> exportType (node val)-                 <*> extractLabel (node name)-    toExport _ = err UnsupportedExport+      toExport :: JSObjectProperty -> m (ExportType, String, JSExpression, [Key])+      toExport (JSPropertyNameandValue name _ [val]) =+        (,,val,[]) <$> exportType val+                   <*> extractLabel' name+      toExport _ = err UnsupportedExport -    exportType :: Node -> m ExportType-    exportType (JSMemberDot [f] _ _)-      | JSIdentifier "$foreign" <- node f-      = pure ForeignReexport-    exportType (JSMemberSquare [f] _ _ _)-      | JSIdentifier "$foreign" <- node f-      = pure ForeignReexport-    exportType (JSIdentifier s) = pure (RegularExport s)-    exportType _ = err UnsupportedExport+      exportType :: JSExpression -> m ExportType+      exportType (JSMemberDot f _ _)+        | JSIdentifier _ "$foreign" <- f+        = pure ForeignReexport+      exportType (JSMemberSquare f _ _ _)+        | JSIdentifier _ "$foreign" <- f+        = pure ForeignReexport+      exportType (JSIdentifier _ s) = pure (RegularExport s)+      exportType _ = err UnsupportedExport -    extractLabel :: Node -> m String-    extractLabel (JSStringLiteral _ nm) = pure nm-    extractLabel (JSIdentifier nm) = pure nm-    extractLabel _ = err UnsupportedExport+      extractLabel' = maybe (err UnsupportedExport) pure . extractLabel -    isSeparator :: Node -> Bool-    isSeparator (JSLiteral ",") = True-    isSeparator _ = False   toModuleElement other = pure (Other other) +-- Get a list of all the exported identifiers from a foreign module.+--+-- TODO: what if we assign to exports.foo and then later assign to+-- module.exports (presumably overwriting exports.foo)?+getExportedIdentifiers :: (MonadError ErrorMessage m)+                          => String+                          -> JSAST+                          -> m [String]+getExportedIdentifiers mname top+  | JSAstProgram stmts _ <- top = concat <$> traverse go stmts+  | otherwise = err InvalidTopLevel+  where+  err = throwError . ErrorInModule (ModuleIdentifier mname Foreign)++  go stmt+    | Just props <- matchExportsAssignment stmt+    = traverse toIdent (trailingCommaList props)+    | Just (True, name, _) <- matchMember stmt+    = pure [name]+    | otherwise+    = pure []++  toIdent (JSPropertyNameandValue name _ [_]) =+    extractLabel' name+  toIdent _ =+    err UnsupportedExport++  extractLabel' = maybe (err UnsupportedExport) pure . extractLabel++-- Matches JS statements like this:+-- var ModuleName = require("file");+matchRequire :: Maybe FilePath+                -> S.Set String+                -> ModuleIdentifier+                -> JSStatement+                -> Maybe (String, Either String ModuleIdentifier)+matchRequire requirePath mids mid stmt+  | JSVariable _ jsInit _ <- stmt+  , [JSVarInitExpression var varInit] <- commaList jsInit+  , JSIdentifier _ importName <- var+  , JSVarInit _ jsInitEx <- varInit+  , JSMemberExpression req _ argsE _ <- jsInitEx+  , JSIdentifier _ "require" <- req+  , [ Just importPath ] <- map fromStringLiteral (commaList argsE)+  , importPath' <- checkImportPath requirePath importPath mid mids+  = Just (importName, importPath')+  | otherwise+  = Nothing++-- Matches JS member declarations.+matchMember :: JSStatement -> Maybe (Bool, String, JSExpression)+matchMember stmt+  -- var foo = expr;+  | JSVariable _ jsInit _ <- stmt+  , [JSVarInitExpression var varInit] <- commaList jsInit+  , JSIdentifier _ name <- var+  , JSVarInit _ decl <- varInit+  = Just (False, name, decl)+  -- exports.foo = expr; exports["foo"] = expr;+  | JSAssignStatement e (JSAssign _) decl _ <- stmt+  , Just name <- accessor e+  = Just (True, name, decl)+  | otherwise+  = Nothing+  where+  accessor :: JSExpression -> Maybe String+  accessor (JSMemberDot exports _ nm)+    | JSIdentifier _ "exports" <- exports+    , JSIdentifier _ name <- nm+    = Just name+  accessor (JSMemberSquare exports _ nm _)+    | JSIdentifier _ "exports" <- exports+    , Just name <- fromStringLiteral nm+    = Just name+  accessor _ = Nothing++-- Matches assignments to module.exports, like this:+-- module.exports = { ... }+matchExportsAssignment :: JSStatement -> Maybe JSObjectPropertyList+matchExportsAssignment stmt+  | JSAssignStatement e (JSAssign _) decl _ <- stmt+  , JSMemberDot module' _ exports <- e+  , JSIdentifier _ "module" <- module'+  , JSIdentifier _ "exports" <- exports+  , JSObjectLiteral _ props _ <- decl+  = Just props+  | otherwise+  = Nothing++extractLabel :: JSPropertyName -> Maybe String+extractLabel (JSPropertyString _ nm) = Just (trimStringQuotes nm)+extractLabel (JSPropertyIdent _ nm) = Just nm+extractLabel _ = Nothing+ -- | Eliminate unused code based on the specified entry point set. compile :: [Module] -> [ModuleIdentifier] -> [Module] compile modules [] = modules@@ -339,10 +404,6 @@       where       go :: [ModuleElement] -> [ModuleElement]       go [] = []-      go (d : Other semi : rest)-        | JSLiteral ";" <- node semi-        , not (isDeclUsed d)-        = go rest       go (d : rest)         | not (isDeclUsed d) = go rest         | otherwise = d : go rest@@ -405,130 +466,121 @@         -> String -- ^ namespace         -> [Module] -- ^ input modules         -> String-codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElementsTop (prelude ++ concatMap moduleToJS ms ++ maybe [] runMain optionsMainModule)))+codeGen optionsMainModule optionsNamespace ms =  renderToString (JSAstProgram (prelude : concatMap moduleToJS ms ++ maybe [] runMain optionsMainModule) JSNoAnnot)   where-  moduleToJS :: Module -> [JSNode]+  moduleToJS :: Module -> [JSStatement]   moduleToJS (Module mn ds) = wrap (moduleName mn) (indent (concatMap declToJS ds))     where-    declToJS :: ModuleElement -> [JSNode]+    declToJS :: ModuleElement -> [JSStatement]     declToJS (Member n _ _ _ _) = [n]     declToJS (Other n) = [n]     declToJS (Require _ nm req) =-      [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n  " ])-                        [ NN (JSVarDecl (sp (JSIdentifier nm))-                                        (sp (JSLiteral "=") : either require (return . moduleReference sp . moduleName) req))-                        ]-                        (nt (JSLiteral ";"))) ]+      [+        JSVariable lfsp+          (cList [+            JSVarInitExpression (JSIdentifier sp nm)+              (JSVarInit sp $ either require (moduleReference sp . moduleName) req )+          ]) (JSSemi JSNoAnnot)+      ]     declToJS (ExportsList exps) = map toExport exps        where-      toExport :: (ExportType, String, JSNode, [Key]) -> JSNode+      toExport :: (ExportType, String, JSExpression, [Key]) -> JSStatement       toExport (_, nm, val, _) =-        NN (JSExpression [ NN (JSMemberSquare [ NT (JSIdentifier "exports") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n  " ] ]-                                              (nt (JSLiteral "["))-                                              (NN (JSExpression [ nt (JSStringLiteral '"' nm) ]))-                                              (nt (JSLiteral "]")))-                         , NN (JSOperator (sp (JSLiteral "=")))-                         , reindent val-                         , nt (JSLiteral ";")-                         ])+        JSAssignStatement+          (JSMemberSquare (JSIdentifier lfsp "exports") JSNoAnnot+            (str nm) JSNoAnnot)+          (JSAssign sp)+          val+          (JSSemi JSNoAnnot) -      reindent :: JSNode -> JSNode-      reindent (NT n _ _) = sp n-      reindent nn = nn+  -- comma lists are reverse-consed+  cList :: [a] -> JSCommaList a+  cList [] = JSLNil+  cList [x] = JSLOne x+  cList l = go $ reverse l+    where+      go [x] = JSLOne x+      go (h:t)= JSLCons (go t) JSNoAnnot h+      go [] = error "Invalid case in comma-list" -  indent :: [JSNode] -> [JSNode]+  indent :: [JSStatement] -> [JSStatement]   indent = everywhere (mkT squash)     where-    squash (NT n pos ann) = NT n (keepCol pos) (map splat ann)-    squash nn = nn+    squash JSNoAnnot = (JSAnnot (TokenPn 0 0 2) [])+    squash (JSAnnot pos ann) = JSAnnot (keepCol pos) (map splat ann)      splat (CommentA pos s) = CommentA (keepCol pos) s     splat (WhiteSpace pos w) = WhiteSpace (keepCol pos) w     splat ann = ann -    keepCol (TokenPn _ _ c) = TokenPn 0 0 (c + 2)+    keepCol (TokenPn _ _ c) = TokenPn 0 0 (if c >= 0 then c + 2 else 2) -  prelude :: [JSNode]-  prelude =-    [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ CommentA tokenPosnEmpty ("// Generated by psc-bundle " ++ showVersion Paths.version)-                                                           , WhiteSpace tokenPosnEmpty "\n"-                                                           ])-                                                           [ NN (JSVarDecl (sp (JSIdentifier optionsNamespace))-                                                                           [ sp (JSLiteral "=")-                                                                           , NN (JSObjectLiteral (sp (JSLiteral "{"))-                                                                                                 []-                                                                                                 (sp (JSLiteral "}")))-                                                                           ])-                                                           ]-                                                           (nt (JSLiteral ";")))-    , lf-    ]+  prelude :: JSStatement+  prelude = JSVariable (JSAnnot tokenPosnEmpty [ CommentA tokenPosnEmpty $ "// Generated by psc-bundle " ++ showVersion Paths.version+                                               , WhiteSpace tokenPosnEmpty "\n" ])+              (cList [+                JSVarInitExpression (JSIdentifier sp optionsNamespace)+                  (JSVarInit sp (emptyObj sp))+              ]) (JSSemi JSNoAnnot) -  require :: String -> [JSNode]-  require mn = [ sp (JSIdentifier "require")-               , NN (JSArguments (nt (JSLiteral "(")) [ nt (JSStringLiteral '"' mn) ] (nt (JSLiteral ")")))-               ]+  require :: String -> JSExpression+  require mn =+    JSMemberExpression (JSIdentifier JSNoAnnot "require") JSNoAnnot (cList [ str mn ]) JSNoAnnot -  moduleReference :: (Node -> JSNode) -> String -> JSNode-  moduleReference f mn =-    NN (JSMemberSquare [ f (JSIdentifier optionsNamespace) ]-                       (nt (JSLiteral "["))-                       (NN (JSExpression [ nt (JSStringLiteral '"' mn) ]))-                       (nt (JSLiteral "]")))+  moduleReference :: JSAnnot -> String -> JSExpression+  moduleReference a mn =+    JSMemberSquare (JSIdentifier a optionsNamespace) JSNoAnnot+      (str mn) JSNoAnnot -  wrap :: String -> [JSNode] -> [JSNode]+  str :: String -> JSExpression+  str s = JSStringLiteral JSNoAnnot $ "\"" ++ s ++ "\""+++  emptyObj :: JSAnnot -> JSExpression+  emptyObj a = JSObjectLiteral a (JSCTLNone JSLNil) JSNoAnnot++  wrap :: String -> [JSStatement] -> [JSStatement]   wrap mn ds =-    [ NN (JSExpression [ NN (JSExpressionParen (nt (JSLiteral "("))-                                               (NN (JSExpression [ NN (JSFunctionExpression (nt (JSLiteral "function"))-                                                                                            []-                                                                                            (nt (JSLiteral "(") ) [nt (JSIdentifier "exports")] (nt (JSLiteral ")"))-                                                                                            (NN (JSBlock [sp (JSLiteral "{")]-                                                                                                         (lf : ds)-                                                                                                         [nl (JSLiteral "}")])))]))-                                               (nt (JSLiteral ")")))-                       , NN (JSArguments (nt (JSLiteral "("))-                                         [ NN (JSExpression [ moduleReference nt mn-                                                            , NN (JSOperator (sp (JSLiteral "=")))-                                                            , NN (JSExpressionBinary "||"-                                                                                     [ moduleReference sp mn ]-                                                                                     (sp (JSLiteral "||"))-                                                                                     [ emptyObj ])-                                                            ])-                                         ]-                                         (nt (JSLiteral ")")))-                       ])-    , nt (JSLiteral ";")-    , lf+    [+    JSMethodCall (JSExpressionParen lf (JSFunctionExpression JSNoAnnot JSIdentNone JSNoAnnot+                                                (JSLOne (JSIdentName JSNoAnnot "exports")) JSNoAnnot+                                                (JSBlock sp (lfHead ds) lf)) -- \n not quite in right place+                                    JSNoAnnot)+                  JSNoAnnot+                  (JSLOne (JSAssignExpression (moduleReference JSNoAnnot mn) (JSAssign sp)+                            (JSExpressionBinary (moduleReference sp mn) (JSBinOpOr sp) (emptyObj sp))))+                  JSNoAnnot+                  (JSSemi JSNoAnnot)     ]     where-    emptyObj = NN (JSObjectLiteral (sp (JSLiteral "{")) [] (nt (JSLiteral "}")))+      lfHead (h:t) = (addAnn (WhiteSpace tokenPosnEmpty "\n  ") h) : t+      lfHead x = x -  runMain :: String -> [JSNode]+      addAnn :: CommentAnnotation -> JSStatement -> JSStatement+      addAnn a (JSExpressionStatement (JSStringLiteral ann s) _) =+        (JSExpressionStatement (JSStringLiteral (appendAnn a ann) s) (JSSemi JSNoAnnot))+      addAnn _ x = x++      appendAnn a JSNoAnnot = (JSAnnot tokenPosnEmpty [a])+      appendAnn a (JSAnnot _ anns) = JSAnnot tokenPosnEmpty (a:anns ++ [WhiteSpace tokenPosnEmpty "  "])++  runMain :: String -> [JSStatement]   runMain mn =-    [ NN (JSExpression [ NN (JSMemberDot [ NN (JSMemberSquare [ nl (JSIdentifier optionsNamespace) ]-                                                              (nt (JSLiteral "["))-                                                              (NN (JSExpression [ nt (JSStringLiteral '"' mn) ]))-                                                              (nt (JSLiteral "]")))-                                         ]-                                         (nt (JSLiteral "."))-                                         (nt (JSIdentifier "main")))-                       , NN (JSArguments (nt (JSLiteral "(")) [] (nt (JSLiteral ")")))-                       ])-    , nt (JSLiteral ";")-    ]+    [JSMethodCall+      (JSMemberDot (moduleReference lf mn) JSNoAnnot+        (JSIdentifier JSNoAnnot "main"))+      JSNoAnnot (cList []) JSNoAnnot (JSSemi JSNoAnnot)] -  nt :: Node -> JSNode-  nt n = NT n tokenPosnEmpty []+  lf :: JSAnnot+  lf = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ] -  lf :: JSNode-  lf = NT (JSLiteral "") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ] -  sp :: Node -> JSNode-  sp n = NT n tokenPosnEmpty [ WhiteSpace tokenPosnEmpty " " ]+  lfsp :: JSAnnot+  lfsp = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n  " ] -  nl :: Node -> JSNode-  nl n = NT n tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ]+  sp :: JSAnnot+  sp = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty " " ]  -- | The bundling function. -- This function performs dead code elimination, filters empty modules

src/Language/PureScript/Docs/AsMarkdown.hs view

@@ -6,6 +6,7 @@   , Docs   , runDocs   , modulesAsMarkdown+  , codeToString   ) where  import Prelude ()

src/Language/PureScript/Docs/RenderedCode/Render.hs view

@@ -44,18 +44,6 @@               ]   match (TypeConstructor (Qualified mn name)) =     Just (ctor (runProperName name) (maybeToContainingModule mn))-  match (ConstrainedType deps ty) =-    Just $ mintersperse sp-            [ syntax "(" <> constraints <> syntax ")"-            , syntax "=>"-            , renderType ty-            ]-    where-    constraints = mintersperse (syntax "," <> sp) (map renderDep deps)-    renderDep :: Constraint -> RenderedCode-    renderDep (pn, tys) =-      let instApp = foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys-      in  renderType instApp   match REmpty =     Just (syntax "()")   match row@RCons{} =@@ -63,6 +51,23 @@   match _ =     Nothing +renderConstraint :: Constraint -> RenderedCode+renderConstraint (pn, tys) =+  let instApp = foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys+  in  renderType instApp++renderConstraints :: [Constraint] -> RenderedCode -> RenderedCode+renderConstraints deps ty =+  mintersperse sp+    [ if length deps == 1+         then constraints+         else syntax "(" <> constraints <> syntax ")"+    , syntax "=>"+    , ty+    ]+  where+    constraints = mintersperse (syntax "," <> sp) (map renderConstraint deps)+ -- | -- Render code representing a Row --@@ -104,6 +109,12 @@   match (KindedType t k) = Just (k, t)   match _ = Nothing +constrained :: Pattern () Type ([Constraint], Type)+constrained = mkPattern match+  where+  match (ConstrainedType deps ty) = Just (deps, ty)+  match _ = Nothing+ matchTypeAtom :: Pattern () Type RenderedCode matchTypeAtom = typeLiterals <+> fmap parens matchType   where@@ -116,6 +127,7 @@   operators =     OperatorTable [ [ AssocL typeApp $ \f x -> f <> sp <> x ]                   , [ AssocR appliedFunction $ \arg ret -> mintersperse sp [arg, syntax "->", ret] ]+                  , [ Wrap constrained $ \deps ty -> renderConstraints deps ty ]                   , [ Wrap forall_ $ \idents ty -> mconcat [syntax "forall", sp, mintersperse sp (map ident idents), syntax ".", sp, ty] ]                   , [ Wrap kinded $ \k ty -> mintersperse sp [ty, syntax "::", renderKind k] ]                   ]

src/Language/PureScript/Errors.hs view

@@ -12,6 +12,7 @@ import Data.Either (lefts, rights) import Data.List (intercalate, transpose, nub, nubBy, sortBy) import Data.Foldable (fold)+import Data.Maybe (maybeToList)  import qualified Data.Map as M @@ -28,6 +29,7 @@ import Language.PureScript.Types import Language.PureScript.Names import Language.PureScript.Kinds+import qualified Language.PureScript.Bundle as Bundle  import qualified Text.PrettyPrint.Boxes as Box @@ -37,11 +39,13 @@  -- | A type of error messages data SimpleErrorMessage-  = ErrorParsingFFIModule FilePath+  = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)   | ErrorParsingModule P.ParseError   | MissingFFIModule ModuleName   | MultipleFFIModules ModuleName [FilePath]   | UnnecessaryFFIModule ModuleName FilePath+  | MissingFFIImplementations ModuleName [Ident]+  | UnusedFFIImplementations ModuleName [Ident]   | CannotGetFileInfo FilePath   | CannotReadFile FilePath   | CannotWriteFile FilePath@@ -149,6 +153,7 @@   | IncorrectAnonymousArgument   | InvalidOperatorInBinder Ident Ident   | DeprecatedRequirePath+  | CannotGeneralizeRecursiveFunction Ident Type   deriving (Show)  -- | Error message hints, providing more detailed information about failure.@@ -223,6 +228,8 @@   MissingFFIModule{} -> "MissingFFIModule"   MultipleFFIModules{} -> "MultipleFFIModules"   UnnecessaryFFIModule{} -> "UnnecessaryFFIModule"+  MissingFFIImplementations{} -> "MissingFFIImplementations"+  UnusedFFIImplementations{} -> "UnusedFFIImplementations"   CannotGetFileInfo{} -> "CannotGetFileInfo"   CannotReadFile{} -> "CannotReadFile"   CannotWriteFile{} -> "CannotWriteFile"@@ -330,6 +337,7 @@   IncorrectAnonymousArgument -> "IncorrectAnonymousArgument"   InvalidOperatorInBinder{} -> "InvalidOperatorInBinder"   DeprecatedRequirePath{} -> "DeprecatedRequirePath"+  CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction"  -- | -- A stack trace for an error@@ -420,6 +428,7 @@   gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts   gSimple (WildcardInferredType ty) = WildcardInferredType <$> f ty   gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty+  gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty    gSimple other = pure other @@ -522,10 +531,11 @@       paras [ line "Unable to write file: "             , indent . line $ path             ]-    renderSimpleErrorMessage (ErrorParsingFFIModule path) =-      paras [ line "Unable to parse foreign module:"-            , indent . line $ path-            ]+    renderSimpleErrorMessage (ErrorParsingFFIModule path extra) =+      paras $ [ line "Unable to parse foreign module:"+              , indent . line $ path+              ] +++              (map (indent . line) (concatMap Bundle.printErrorMessage (maybeToList extra)))     renderSimpleErrorMessage (ErrorParsingModule err) =       paras [ line "Unable to parse module: "             , prettyPrintParseError err@@ -537,6 +547,14 @@             , indent . line $ path             , line $ "Module " ++ runModuleName mn ++ " does not contain any foreign import declarations, so a foreign module is not necessary."             ]+    renderSimpleErrorMessage (MissingFFIImplementations mn idents) =+      paras [ line $ "The following values are not defined in the foreign module for module " ++ runModuleName mn ++ ": "+            , indent . paras $ map (line . runIdent) idents+            ]+    renderSimpleErrorMessage (UnusedFFIImplementations mn idents) =+      paras [ line $ "The following definitions in the foreign module for module " ++ runModuleName mn ++ " are unused: "+            , indent . paras $ map (line . runIdent) idents+            ]     renderSimpleErrorMessage (MultipleFFIModules mn paths) =       paras [ line $ "Multiple foreign module implementations have been provided for module " ++ runModuleName mn ++ ": "             , indent . paras $ map line paths@@ -981,6 +999,13 @@     renderSimpleErrorMessage DeprecatedRequirePath =       line "The require-path option is deprecated and will be removed in PureScript 0.9." +    renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) =+      paras [ line $ "Unable to generalize the type of the recursive function " ++ showIdent ident ++ "."+            , line $ "The inferred type of " ++ showIdent ident ++ " was:"+            , indent $ typeAsBox ty+            , line "Try adding a type signature."+            ]+     renderHint :: ErrorMessageHint -> Box.Box -> Box.Box     renderHint (ErrorUnifyingTypes t1 t2) detail =       paras [ detail@@ -1202,7 +1227,7 @@  -- | Pretty print errors as a Box prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> [Box.Box]-prettyPrintMultipleErrorsBox = prettyPrintMultipleErrorsWith Error "Error found:" "Error" +prettyPrintMultipleErrorsBox = prettyPrintMultipleErrorsWith Error "Error found:" "Error"  prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> [Box.Box] prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) =

src/Language/PureScript/Ide.hs view

@@ -1,3 +1,17 @@+-----------------------------------------------------------------------------+--+-- Module      : Language.PureScript.Ide+-- Description : Interface for the psc-ide-server+-- Copyright   : Christoph Hegemann 2016+-- License     : MIT (http://opensource.org/licenses/MIT)+--+-- Maintainer  : Christoph Hegemann <christoph.hegemann1337@gmail.com>+-- Stability   : experimental+--+-- |+-- Interface for the psc-ide-server+-----------------------------------------------------------------------------+ {-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -6,7 +20,11 @@ {-# LANGUAGE TemplateHaskell       #-} {-# LANGUAGE TupleSections         #-} -module Language.PureScript.Ide where+module Language.PureScript.Ide+       ( handleCommand+         -- for tests+       , printModules+       ) where  import           Prelude                            () import           Prelude.Compat@@ -27,12 +45,14 @@ import           Language.PureScript.Ide.Error import           Language.PureScript.Ide.Externs import           Language.PureScript.Ide.Filter+import           Language.PureScript.Ide.Imports hiding (Import) import           Language.PureScript.Ide.Matcher import           Language.PureScript.Ide.Pursuit import           Language.PureScript.Ide.Reexports import           Language.PureScript.Ide.SourceFile import           Language.PureScript.Ide.State import           Language.PureScript.Ide.Types+import           Language.PureScript.Ide.Util import           System.Directory import           System.FilePath import           System.Exit@@ -40,39 +60,48 @@  handleCommand :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>                  Command -> m Success+handleCommand (Load [] []) = loadAllModules handleCommand (Load modules deps) =-    loadModulesAndDeps modules deps+  loadModulesAndDeps modules deps handleCommand (Type search filters) =-    findType search filters+  findType search filters handleCommand (Complete filters matcher) =-    findCompletions filters matcher+  findCompletions filters matcher handleCommand (Pursuit query Package) =-    findPursuitPackages query+  findPursuitPackages query handleCommand (Pursuit query Identifier) =-    findPursuitCompletions query+  findPursuitCompletions query handleCommand (List LoadedModules) =-    printModules+  printModules handleCommand (List AvailableModules) =-    listAvailableModules+  listAvailableModules handleCommand (List (Imports fp)) =-    importsForFile fp+  importsForFile fp handleCommand (CaseSplit l b e wca t) =-    caseSplit l b e wca t+  caseSplit l b e wca t handleCommand (AddClause l wca) =-    pure $ addClause l wca+  pure $ addClause l wca+handleCommand (Import fp outfp _ (AddImplicitImport mn)) = do+  rs <- addImplicitImport fp mn+  answerRequest outfp rs+handleCommand (Import fp outfp filters (AddImportForIdentifier ident)) = do+  rs <- addImportForIdentifier fp ident filters+  case rs of+    Right rs' -> answerRequest outfp rs'+    Left question -> pure $ CompletionResult (mapMaybe completionFromMatch question) handleCommand Cwd =-    TextResult . T.pack <$> liftIO getCurrentDirectory+  TextResult . T.pack <$> liftIO getCurrentDirectory handleCommand Quit = liftIO exitSuccess  findCompletions :: (PscIde m, MonadLogger m) =>                    [Filter] -> Matcher -> m Success findCompletions filters matcher =-  CompletionResult . getCompletions filters matcher <$> getAllModulesWithReexports+  CompletionResult . mapMaybe completionFromMatch . getCompletions filters matcher <$> getAllModulesWithReexports  findType :: (PscIde m, MonadLogger m) =>             DeclIdent -> [Filter] -> m Success findType search filters =-  CompletionResult . getExactMatches search filters <$> getAllModulesWithReexports+  CompletionResult . mapMaybe completionFromMatch . getExactMatches search filters <$> getAllModulesWithReexports  findPursuitCompletions :: (MonadIO m, MonadLogger m) =>                           PursuitQuery -> m Success@@ -179,6 +208,26 @@   $(logDebug) ("Loaded extern file at: " <> T.pack path)   pure ("Loaded extern file at: " <> T.pack path) +loadAllModules :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => m Success+loadAllModules = do+  outputPath <- confOutputPath . envConfiguration <$> ask+  cwd <- liftIO getCurrentDirectory+  let outputDirectory = cwd </> outputPath+  liftIO (getDirectoryContents outputDirectory)+    >>= liftIO . traverse (getExternsPath outputDirectory)+    >>= traverse_ loadExtern . catMaybes+  pure (TextResult "All modules loaded.")+  where+    getExternsPath :: FilePath -> FilePath -> IO (Maybe FilePath)+    getExternsPath outputDirectory d+      | d `elem` [".", ".."] = pure Nothing+      | otherwise = do+          let file = outputDirectory </> d </> "externs.json"+          ex <- doesFileExist file+          if ex+            then pure (Just file)+            else pure Nothing+ filePathFromModule :: (PscIde m, MonadError PscIdeError m) =>                       ModuleIdent -> m FilePath filePathFromModule moduleName = do@@ -190,10 +239,3 @@     then pure path     else throwError (ModuleFileNotFound moduleName) --- | Taken from Data.Either.Utils-maybeToEither :: MonadError e m =>-                 e                      -- ^ (Left e) will be returned if the Maybe value is Nothing-              -> Maybe a                -- ^ (Right a) will be returned if this is (Just a)-              -> m a-maybeToEither errorval Nothing = throwError errorval-maybeToEither _ (Just normalval) = return normalval

src/Language/PureScript/Ide/CaseSplit.hs view

@@ -1,3 +1,17 @@+-----------------------------------------------------------------------------+--+-- Module      : Language.PureScript.Ide.CaseSplit+-- Description : Casesplitting and adding function clauses+-- Copyright   : Christoph Hegemann 2016+-- License     : MIT (http://opensource.org/licenses/MIT)+--+-- Maintainer  : Christoph Hegemann <christoph.hegemann1337@gmail.com>+-- Stability   : experimental+--+-- |+-- Casesplitting and adding function clauses+-----------------------------------------------------------------------------+ {-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE DataKinds             #-} {-# LANGUAGE FlexibleContexts      #-}@@ -26,24 +40,19 @@ import           Data.Monoid import           Data.Text                               (Text) import qualified Data.Text                               as T-import           Language.PureScript.AST-import           Language.PureScript.Environment+import qualified Language.PureScript                     as P+ import           Language.PureScript.Externs import           Language.PureScript.Ide.Error import           Language.PureScript.Ide.Externs         (unwrapPositioned) import           Language.PureScript.Ide.State-import           Language.PureScript.Ide.Types           hiding (Type)-import           Language.PureScript.Names-import           Language.PureScript.Parser.Common       (runTokenParser)-import           Language.PureScript.Parser.Declarations-import           Language.PureScript.Parser.Lexer        (lex)-import           Language.PureScript.Parser.Types-import           Language.PureScript.Pretty-import           Language.PureScript.Types-import           Text.Parsec                             as P+import           Language.PureScript.Ide.Types+import           Language.PureScript.Ide.Util -type Constructor = (ProperName 'ConstructorName, [Type])+import           Text.Parsec                             as Parsec +type Constructor = (P.ProperName 'P.ConstructorName, [P.Type])+ newtype WildcardAnnotations = WildcardAnnotations Bool  explicitAnnotations :: WildcardAnnotations@@ -57,13 +66,13 @@ caseSplit q = do   type' <- parseType' (T.unpack q)   (tc, args) <- splitTypeConstructor type'-  (EDType _ _ (DataType typeVars ctors)) <- findTypeDeclaration tc-  let applyTypeVars = everywhereOnTypes (replaceAllTypeVars (zip (map fst typeVars) args))+  (EDType _ _ (P.DataType typeVars ctors)) <- findTypeDeclaration tc+  let applyTypeVars = P.everywhereOnTypes (P.replaceAllTypeVars (zip (map fst typeVars) args))   let appliedCtors = map (second (map applyTypeVars)) ctors   pure appliedCtors  findTypeDeclaration :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>-                         ProperName 'TypeName -> m ExternsDeclaration+                         P.ProperName 'P.TypeName -> m ExternsDeclaration findTypeDeclaration q = do   efs <- getExternFiles   let m = getFirst $ foldMap (findTypeDeclaration' q) efs@@ -72,7 +81,7 @@     Nothing -> throwError (GeneralError "Not Found")  findTypeDeclaration' ::-  ProperName 'TypeName+  P.ProperName 'P.TypeName   -> ExternsFile   -> First ExternsDeclaration findTypeDeclaration' t ExternsFile{..} =@@ -81,25 +90,25 @@             _ -> False) efDeclarations  splitTypeConstructor :: (MonadError PscIdeError m) =>-                        Type -> m (ProperName 'TypeName, [Type])+                        P.Type -> m (P.ProperName 'P.TypeName, [P.Type]) splitTypeConstructor = go []   where-    go acc (TypeApp ty arg) = go (arg : acc) ty-    go acc (TypeConstructor tc) = pure (disqualify tc, acc)+    go acc (P.TypeApp ty arg) = go (arg : acc) ty+    go acc (P.TypeConstructor tc) = pure (P.disqualify tc, acc)     go _ _ = throwError (GeneralError "Failed to read TypeConstructor")  prettyCtor :: WildcardAnnotations -> Constructor -> Text-prettyCtor _ (ctorName, []) = T.pack (runProperName ctorName)+prettyCtor _ (ctorName, []) = runProperNameT ctorName prettyCtor wsa (ctorName, ctorArgs) =-  "("<> T.pack (runProperName ctorName) <> " "+  "("<> runProperNameT ctorName <> " "   <> T.unwords (map (prettyPrintWildcard wsa) ctorArgs) <>")" -prettyPrintWildcard :: WildcardAnnotations -> Type -> Text+prettyPrintWildcard :: WildcardAnnotations -> P.Type -> Text prettyPrintWildcard (WildcardAnnotations True) = prettyWildcard prettyPrintWildcard (WildcardAnnotations False) = const "_" -prettyWildcard :: Type -> Text-prettyWildcard t = "( _ :: " <> T.strip (T.pack (prettyPrintTypeAtom t)) <> ")"+prettyWildcard :: P.Type -> Text+prettyWildcard t = "( _ :: " <> T.strip (T.pack (P.prettyPrintTypeAtom t)) <> ")"  -- | Constructs Patterns to insert into a sourcefile makePattern :: Text -- ^ Current line@@ -116,38 +125,38 @@ addClause s wca =   let (fName, fType) = parseTypeDeclaration' (T.unpack s)       (args, _) = splitFunctionType fType-      template = T.pack (runIdent fName) <> " " <>+      template = runIdentT fName <> " " <>         T.unwords (map (prettyPrintWildcard wca) args) <>-        " = ?" <> (T.strip . T.pack . runIdent $ fName)+        " = ?" <> (T.strip . runIdentT $ fName)   in [s, template]  parseType' :: (MonadError PscIdeError m) =>-              String -> m Type+              String -> m P.Type parseType' s =-  case lex "<psc-ide>" s >>= runTokenParser "<psc-ide>" (parseType <* P.eof) of+  case P.lex "<psc-ide>" s >>= P.runTokenParser "<psc-ide>" (P.parseType <* Parsec.eof) of     Right type' -> pure type'     Left err ->       throwError (GeneralError ("Parsing the splittype failed with:"                                 ++ show err)) -parseTypeDeclaration' :: String -> (Ident, Type)+parseTypeDeclaration' :: String -> (P.Ident, P.Type) parseTypeDeclaration' s =   let x = do-        ts <- lex "" s-        runTokenParser "" (parseDeclaration <* P.eof) ts+        ts <- P.lex "" s+        P.runTokenParser "" (P.parseDeclaration <* Parsec.eof) ts   in     case unwrapPositioned <$> x of-      Right (TypeDeclaration i t) -> (i, t)+      Right (P.TypeDeclaration i t) -> (i, t)       y -> error (show y) -splitFunctionType :: Type -> ([Type], Type)+splitFunctionType :: P.Type -> ([P.Type], P.Type) splitFunctionType t = (arguments, returns)   where     returns = last splitted     arguments = init splitted     splitted = splitType' t-    splitType' (ForAll _ t' _) = splitType' t'-    splitType' (ConstrainedType _ t') = splitType' t'-    splitType' (TypeApp (TypeApp t' lhs) rhs)-          | t' == tyFunction = lhs : splitType' rhs+    splitType' (P.ForAll _ t' _) = splitType' t'+    splitType' (P.ConstrainedType _ t') = splitType' t'+    splitType' (P.TypeApp (P.TypeApp t' lhs) rhs)+          | t' == P.tyFunction = lhs : splitType' rhs     splitType' t' = [t']

− src/Language/PureScript/Ide/CodecJSON.hs

@@ -1,13 +0,0 @@-module Language.PureScript.Ide.CodecJSON where--import Data.Aeson-import Data.Text (Text())-import Data.Text.Lazy (toStrict, fromStrict)-import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)--encodeT :: (ToJSON a) => a -> Text-encodeT = toStrict . decodeUtf8 . encode--decodeT :: (FromJSON a) => Text -> Maybe a-decodeT = decode . encodeUtf8 . fromStrict-

src/Language/PureScript/Ide/Command.hs view

@@ -1,3 +1,17 @@+-----------------------------------------------------------------------------+--+-- Module      : Language.PureScript.Ide.Command+-- Description : Datatypes for the commands psc-ide accepts+-- Copyright   : Christoph Hegemann 2016+-- License     : MIT (http://opensource.org/licenses/MIT)+--+-- Maintainer  : Christoph Hegemann <christoph.hegemann1337@gmail.com>+-- Stability   : experimental+--+-- |+-- Datatypes for the commands psc-ide accepts+-----------------------------------------------------------------------------+ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE ScopedTypeVariables   #-}@@ -11,33 +25,64 @@ import           Data.Aeson import           Data.Maybe import           Data.Text                         (Text)+import           Language.PureScript               (ModuleName,+                                                    moduleNameFromString) import           Language.PureScript.Ide.CaseSplit import           Language.PureScript.Ide.Filter import           Language.PureScript.Ide.Matcher import           Language.PureScript.Ide.Types  data Command-    = Load { loadModules      :: [ModuleIdent]-           , loadDependencies :: [ModuleIdent]}-    | Type { typeSearch  :: DeclIdent-           , typeFilters :: [Filter]}-    | Complete { completeFilters :: [Filter]-               , completeMatcher :: Matcher}-    | Pursuit { pursuitQuery      :: PursuitQuery-              , pursuitSearchType :: PursuitSearchType}-    | List {listType :: ListType}-    | CaseSplit {-      caseSplitLine          :: Text+    = Load+      { loadModules      :: [ModuleIdent]+      , loadDependencies :: [ModuleIdent]+      }+    | Type+      { typeSearch  :: DeclIdent+      , typeFilters :: [Filter]+      }+    | Complete+      { completeFilters :: [Filter]+      , completeMatcher :: Matcher+      }+    | Pursuit+      { pursuitQuery      :: PursuitQuery+      , pursuitSearchType :: PursuitSearchType+      }+    | CaseSplit+      { caseSplitLine        :: Text       , caseSplitBegin       :: Int       , caseSplitEnd         :: Int       , caseSplitAnnotations :: WildcardAnnotations-      , caseSplitType        :: Type}-    | AddClause {-      addClauseLine          :: Text-      , addClauseAnnotations :: WildcardAnnotations}+      , caseSplitType        :: Text+      }+    | AddClause+      { addClauseLine        :: Text+      , addClauseAnnotations :: WildcardAnnotations+      }+      -- Import InputFile OutputFile+    | Import FilePath (Maybe FilePath) [Filter] ImportCommand+    | List { listType :: ListType }     | Cwd     | Quit +data ImportCommand+  = AddImplicitImport ModuleName+  | AddImportForIdentifier DeclIdent+  deriving (Show, Eq)++instance FromJSON ImportCommand where+  parseJSON = withObject "ImportCommand" $ \o -> do+    (command :: String) <- o .: "importCommand"+    case command of+      "addImplicitImport" -> do+        mn <- o .: "module"+        pure (AddImplicitImport (moduleNameFromString mn))+      "addImport" -> do+        ident <- o .: "identifier"+        pure (AddImportForIdentifier ident)+      _ -> mzero+ data ListType = LoadedModules | Imports FilePath | AvailableModules  instance FromJSON ListType where@@ -60,11 +105,11 @@         return $ List (fromMaybe LoadedModules listType')       "cwd"  -> return Cwd       "quit" -> return Quit-      "load" -> do-        params <- o .: "params"-        mods <- params .:? "modules"-        deps <- params .:? "dependencies"-        return $ Load (fromMaybe [] mods) (fromMaybe [] deps)+      "load" ->+        maybe (pure (Load [] [])) (\params -> do+          mods <- params .:? "modules"+          deps <- params .:? "dependencies"+          pure $ Load (fromMaybe [] mods) (fromMaybe [] deps)) =<< o .:? "params"       "type" -> do         params <- o .: "params"         search <- params .: "search"@@ -97,5 +142,12 @@         return $ AddClause line (if annotations                                  then explicitAnnotations                                  else noAnnotations)+      "import" -> do+        params <- o .: "params"+        fp <- params .: "file"+        out <- params .:? "outfile"+        filters <- params .:? "filters"+        importCommand <- params .: "importCommand"+        pure $ Import fp out (fromMaybe [] filters) importCommand       _ -> mzero

src/Language/PureScript/Ide/Completion.hs view

@@ -13,23 +13,20 @@  -- | 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 :: [Filter] -> Matcher -> [Module] -> [Match] getCompletions filters matcher modules =     runMatcher matcher $ completionsFromModules (applyFilters filters modules) -getExactMatches :: DeclIdent -> [Filter] -> [Module] -> [Completion]+getExactMatches :: DeclIdent -> [Filter] -> [Module] -> [Match] getExactMatches search filters modules =     completionsFromModules $     applyFilters (equalityFilter search : filters) modules -completionsFromModules :: [Module] -> [Completion]+completionsFromModules :: [Module] -> [Match] completionsFromModules = foldMap completionFromModule   where-    completionFromModule :: Module -> [Completion]-    completionFromModule (moduleIdent, decls) = mapMaybe (completionFromDecl moduleIdent) decls+    completionFromModule :: Module -> [Match]+    completionFromModule (moduleIdent, decls) = mapMaybe (matchFromDecl moduleIdent) decls -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 _  (ModuleDecl name _)       = Just (Completion ("module", name, "module"))-completionFromDecl _ _                          = Nothing+matchFromDecl :: ModuleIdent -> ExternDecl -> Maybe Match+matchFromDecl mi = Just . Match mi

src/Language/PureScript/Ide/Error.hs view

@@ -1,6 +1,20 @@+-----------------------------------------------------------------------------+--+-- Module      : Language.PureScript.Ide.Error+-- Description : Error types for psc-ide+-- Copyright   : Christoph Hegemann 2016+-- License     : MIT (http://opensource.org/licenses/MIT)+--+-- Maintainer  : Christoph Hegemann <christoph.hegemann1337@gmail.com>+-- Stability   : experimental+--+-- |+-- Error types for psc-ide+-----------------------------------------------------------------------------+ {-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.Error-       (ErrorMsg, PscIdeError(..), textError, first)+       (ErrorMsg, PscIdeError(..), textError)        where  import           Data.Aeson@@ -35,8 +49,3 @@     -- escape newlines and other special chars so we can send the error over the socket as a single line     escape :: P.ParseError -> String     escape = show---- | Specialized version of `first` from `Data.Bifunctors`-first :: (a -> b) -> Either a r -> Either b r-first f (Left x)   = Left (f x)-first _ (Right r2) = Right r2

src/Language/PureScript/Ide/Externs.hs view

@@ -1,3 +1,17 @@+-----------------------------------------------------------------------------+--+-- Module      : Language.PureScript.Ide.Externs+-- Description : Handles externs files for psc-ide+-- Copyright   : Christoph Hegemann 2016+-- License     : MIT (http://opensource.org/licenses/MIT)+--+-- Maintainer  : Christoph Hegemann <christoph.hegemann1337@gmail.com>+-- Stability   : experimental+--+-- |+-- Handles externs files for psc-ide+-----------------------------------------------------------------------------+ {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings     #-}@@ -5,35 +19,33 @@ {-# LANGUAGE ScopedTypeVariables   #-}  module Language.PureScript.Ide.Externs-  (-    ExternDecl(..),+  ( ExternDecl(..),     ModuleIdent,     DeclIdent,-    Type,-    Fixity(..),     readExternFile,     convertExterns,     unwrapPositioned,     unwrapPositionedRef   ) where -import           Prelude                              ()+import           Prelude                       () import           Prelude.Compat  import           Control.Monad.Error.Class import           Control.Monad.IO.Class-import           Data.Maybe                           (mapMaybe)-import           Data.Text                            (Text)-import qualified Data.Text                            as T-import qualified Data.Text.IO                         as T-import qualified Language.PureScript.AST.Declarations as D-import qualified Language.PureScript.Externs          as PE-import           Language.PureScript.Ide.CodecJSON-import           Language.PureScript.Ide.Error        (PscIdeError (..))+import           Data.List                     (nub)+import           Data.Maybe                    (mapMaybe)+import           Data.Monoid+import           Data.Text                     (Text)+import qualified Data.Text                     as T+import qualified Data.Text.IO                  as T+import           Language.PureScript.Ide.Error (PscIdeError (..)) import           Language.PureScript.Ide.Types-import qualified Language.PureScript.Names            as N-import qualified Language.PureScript.Pretty           as PP+import           Language.PureScript.Ide.Util +import qualified Language.PureScript           as P+import qualified Language.PureScript.Externs   as PE+ readExternFile :: (MonadIO m, MonadError PscIdeError m) =>                   FilePath -> m PE.ExternsFile readExternFile fp = do@@ -42,17 +54,14 @@      Nothing -> throwError . GeneralError $ "Parsing the extern at: " ++ fp ++ " failed"      Just externs -> pure externs -moduleNameToText :: N.ModuleName -> Text-moduleNameToText = T.pack . N.runModuleName--properNameToText :: N.ProperName a -> Text-properNameToText = T.pack . N.runProperName+moduleNameToText :: P.ModuleName -> Text+moduleNameToText = T.pack . P.runModuleName -identToText :: N.Ident -> Text-identToText  = T.pack . N.runIdent+identToText :: P.Ident -> Text+identToText  = T.pack . P.runIdent  convertExterns :: PE.ExternsFile -> Module-convertExterns ef = (moduleName, exportDecls ++ importDecls ++ otherDecls)+convertExterns ef = (moduleName, exportDecls ++ importDecls ++ decls)   where     moduleName = moduleNameToText (PE.efModuleName ef)     importDecls = convertImport <$> PE.efImports ef@@ -61,42 +70,45 @@     -- operatorDecls = convertOperator <$> PE.efFixities ef     otherDecls = mapMaybe convertDecl (PE.efDeclarations ef) +    typeClassFilter = foldMap removeTypeDeclarationsForClass (filter isTypeClassDeclaration otherDecls)+    decls = nub $ appEndo typeClassFilter otherDecls++removeTypeDeclarationsForClass :: ExternDecl -> Endo [ExternDecl]+removeTypeDeclarationsForClass (TypeClassDeclaration n) = Endo (filter notDuplicate)+  where notDuplicate (TypeDeclaration n' _) = runProperNameT n /= runProperNameT n'+        notDuplicate (TypeSynonymDeclaration n' _) = runProperNameT n /= runProperNameT n'+        notDuplicate _ = True+removeTypeDeclarationsForClass _ = mempty++isTypeClassDeclaration :: ExternDecl -> Bool+isTypeClassDeclaration TypeClassDeclaration{} = True+isTypeClassDeclaration _ = False+ convertImport :: PE.ExternsImport -> ExternDecl convertImport ei = Dependency   (moduleNameToText (PE.eiModule ei))   []   (moduleNameToText <$> PE.eiImportedAs ei) -convertExport :: D.DeclarationRef -> Maybe ExternDecl-convertExport (D.ModuleRef mn) = Just (Export (moduleNameToText mn))+convertExport :: P.DeclarationRef -> Maybe ExternDecl+convertExport (P.ModuleRef mn) = Just (Export (moduleNameToText mn)) convertExport _ = Nothing  convertDecl :: PE.ExternsDeclaration -> Maybe ExternDecl-convertDecl PE.EDType{..} = Just $-  DataDecl-  (properNameToText edTypeName)-  (packAndStrip (PP.prettyPrintKind edTypeKind))+convertDecl PE.EDType{..} = Just $ TypeDeclaration edTypeName edTypeKind convertDecl PE.EDTypeSynonym{..} = Just $-  DataDecl-  (properNameToText edTypeSynonymName)-  (packAndStrip (PP.prettyPrintType edTypeSynonymType))+  TypeSynonymDeclaration edTypeSynonymName edTypeSynonymType convertDecl PE.EDDataConstructor{..} = Just $-  DataDecl-  (properNameToText edDataCtorName)-  (packAndStrip (PP.prettyPrintType edDataCtorType))+  DataConstructor (runProperNameT edDataCtorName) edDataCtorTypeCtor edDataCtorType convertDecl PE.EDValue{..} = Just $-  FunctionDecl-  (identToText edValueName)-  (packAndStrip (PP.prettyPrintType edValueType))-convertDecl _ = Nothing--packAndStrip :: String -> Text-packAndStrip = T.unwords . fmap T.strip . T.lines . T.pack+  ValueDeclaration (identToText edValueName) edValueType+convertDecl PE.EDClass{..} = Just $ TypeClassDeclaration edClassName+convertDecl PE.EDInstance{} = Nothing -unwrapPositioned :: D.Declaration -> D.Declaration-unwrapPositioned (D.PositionedDeclaration _ _ x) = x+unwrapPositioned :: P.Declaration -> P.Declaration+unwrapPositioned (P.PositionedDeclaration _ _ x) = x unwrapPositioned x = x -unwrapPositionedRef :: D.DeclarationRef -> D.DeclarationRef-unwrapPositionedRef (D.PositionedDeclarationRef _ _ x) = x+unwrapPositionedRef :: P.DeclarationRef -> P.DeclarationRef+unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = x unwrapPositionedRef x = x

src/Language/PureScript/Ide/Filter.hs view

@@ -1,10 +1,30 @@+-----------------------------------------------------------------------------+--+-- Module      : Language.PureScript.Ide.Filter+-- Description : Filters for psc-ide commands+-- Copyright   : Christoph Hegemann 2016+-- License     : MIT (http://opensource.org/licenses/MIT)+--+-- Maintainer  : Christoph Hegemann <christoph.hegemann1337@gmail.com>+-- Stability   : experimental+--+-- |+-- Filters for psc-ide commands+-----------------------------------------------------------------------------+ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE ScopedTypeVariables        #-}+ module Language.PureScript.Ide.Filter-       (Filter, moduleFilter, prefixFilter, equalityFilter, dependencyFilter,-        runFilter, applyFilters)-       where+       ( Filter+       , moduleFilter+       , prefixFilter+       , equalityFilter+       , dependencyFilter+       , runFilter+       , applyFilters+       ) where  import           Prelude                       () import           Prelude.Compat@@ -16,6 +36,7 @@ import           Data.Monoid import           Data.Text                     (Text, isPrefixOf) import           Language.PureScript.Ide.Types+import           Language.PureScript.Ide.Util  newtype Filter = Filter (Endo [Module]) deriving(Monoid) @@ -57,10 +78,9 @@ prefixFilter t = mkFilter $ identFilter prefix t   where     prefix :: ExternDecl -> Text -> Bool-    prefix (FunctionDecl name _) search = search `isPrefixOf` name-    prefix (DataDecl name _) search = search `isPrefixOf` name-    prefix (ModuleDecl name _) search = search `isPrefixOf` name-    prefix _ _ = False+    prefix Export{} _ = False+    prefix Dependency{} _ = False+    prefix ed search = search `isPrefixOf` identifierFromExternDecl ed   -- | Only keeps Identifiers that are equal to the search string@@ -68,10 +88,7 @@ equalityFilter = mkFilter . identFilter equality   where     equality :: ExternDecl -> Text -> Bool-    equality (FunctionDecl name _) prefix = prefix == name-    equality (DataDecl name _) prefix = prefix == name-    equality _ _ = False-+    equality ed search = identifierFromExternDecl ed == search  identFilter :: (ExternDecl -> Text -> Bool ) -> Text -> [Module] -> [Module] identFilter predicate search =

+ src/Language/PureScript/Ide/Imports.hs view

@@ -0,0 +1,355 @@+-----------------------------------------------------------------------------+--+-- Module      : Language.PureScript.Ide.Imports+-- Description : Provides functionality to manage imports+-- Copyright   : Christoph Hegemann 2016+-- License     : MIT (http://opensource.org/licenses/MIT)+--+-- Maintainer  : Christoph Hegemann <christoph.hegemann1337@gmail.com>+-- Stability   : experimental+--+-- |+-- Provides functionality to manage imports+-----------------------------------------------------------------------------++{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PackageImports        #-}++module Language.PureScript.Ide.Imports+       ( addImplicitImport+       , addImportForIdentifier+       , answerRequest+         -- for tests+       , parseImport+       , prettyPrintImportSection+       , addImplicitImport'+       , addExplicitImport'+       , sliceImportSection+       , prettyPrintImport'+       , Import(Import)+       )+       where++import           Control.Applicative                ((<|>))+import           Control.Monad.Error.Class+import           Control.Monad.IO.Class+import           "monad-logger" Control.Monad.Logger+import           Data.Bifunctor                     (first, second)+import           Data.Function                      (on)+import qualified Data.List                          as List+import           Data.Maybe                         (isNothing)+import           Data.Monoid                        ((<>))+import           Data.Text                          (Text)+import qualified Data.Text                          as T+import qualified Data.Text.IO                       as TIO+import qualified Language.PureScript                as P+import           Language.PureScript.Ide.Completion+import           Language.PureScript.Ide.Error+import           Language.PureScript.Ide.Externs    (unwrapPositioned,+                                                     unwrapPositionedRef)+import           Language.PureScript.Ide.Filter+import           Language.PureScript.Ide.State+import           Language.PureScript.Ide.Types+import           Language.PureScript.Ide.Util++data Import = Import P.ModuleName P.ImportDeclarationType  (Maybe P.ModuleName)+              deriving (Eq, Show)++instance Ord Import where+  compare = compImport++compImportType :: P.ImportDeclarationType -> P.ImportDeclarationType -> Ordering+compImportType P.Implicit P.Implicit = EQ+compImportType P.Implicit _ = LT+compImportType (P.Explicit _) (P.Hiding _) = LT+compImportType (P.Explicit _) (P.Explicit _) = EQ+compImportType (P.Explicit _) P.Implicit = GT+compImportType (P.Hiding _) (P.Hiding _) = EQ+compImportType (P.Hiding _) _ = GT++compImport :: Import -> Import -> Ordering+compImport (Import n i q) (Import n' i' q')+  | compImportType i i' /= EQ = compImportType i i'+    -- This means that for a stable sort, the first implicit import will stay+    -- the first implicit import+  | P.isImplicit i && isNothing q = LT+  | P.isImplicit i && isNothing q' = GT+  | otherwise = compare n n'++-- | Reads a file and returns the (lines before the imports, the imports, the+-- lines after the imports)+parseImportsFromFile :: (MonadIO m, MonadError PscIdeError m) =>+                        FilePath -> m (P.ModuleName, [Text], [Import], [Text])+parseImportsFromFile fp = do+  file <- liftIO (TIO.readFile fp)+  case sliceImportSection (T.lines file) of+    Right res -> pure res+    Left err -> throwError (GeneralError err)++parseImportsWithModuleName :: [Text] -> Either String (P.ModuleName, [Import])+parseImportsWithModuleName ls = do+  (P.Module _ _ mn decls _) <- moduleParse ls+  pure (mn, concatMap mkImport (unwrapPositioned <$> decls))+  where+    mkImport (P.ImportDeclaration mn (P.Explicit refs) qual _) =+      [Import mn (P.Explicit (unwrapPositionedRef <$> refs)) qual]+    mkImport (P.ImportDeclaration mn it qual _) = [Import mn it qual]+    mkImport _ = []++sliceImportSection :: [Text] -> Either String (P.ModuleName, [Text], [Import], [Text])+sliceImportSection ts =+  case foldl step (ModuleHeader 0) (zip [0..] ts) of+    Res start end ->+      let+        (moduleHeader, (importSection, remainingFile)) =+          List.splitAt (succ (end - start)) `second` List.splitAt start ts+      in+        (\(mn, is) -> (mn, moduleHeader, is, remainingFile)) <$>+          parseImportsWithModuleName (moduleHeader <> importSection)++    -- If we don't find any imports, we insert a newline after the module+    -- declaration and begin a new importsection+    ModuleHeader ix ->+      let (moduleHeader, remainingFile) = List.splitAt (succ ix) ts+      in+        (\(mn, is) -> (mn, moduleHeader ++ [""], is, remainingFile)) <$>+          parseImportsWithModuleName moduleHeader+    _ -> Left "Failed to detect the import section"++data ImportStateMachine = ModuleHeader Int | ImportSection Int Int | Res Int Int++-- | We start in the+--+-- * ModuleHeader state.+--+-- We skip every line we encounter, that doesn't start with "import". If we find+-- a line that starts with module we store that linenumber. Once we find a line+-- with "import" we store its linenumber as the start of the import section and+-- change into the+--+-- * ImportSection state+--+-- For any line that starts with import or whitespace(is thus indented) we+-- expand the end of the import section to that line and continue. If we+-- encounter a commented or empty line, we continue moving forward in the+-- ImportSection state but don't expand the import section end yet. This allows+-- us to exclude newlines or comments that directly follow the import section.+-- Once we encounter a line that is not a comment, newline, indentation or+-- import we switch into the+--+-- * Res state+--+-- , which just shortcuts to the end of the file and carries the detected import+-- section boundaries+step :: ImportStateMachine -> (Int, Text) -> ImportStateMachine+step (ModuleHeader mi) (ix, l)+  | T.isPrefixOf "module " l = ModuleHeader ix+  | T.isPrefixOf "import " l = ImportSection ix ix+  | otherwise = ModuleHeader mi+step (ImportSection start lastImportLine) (ix, l)+  | any (`T.isPrefixOf` l) ["import", " "] = ImportSection start ix+  | T.isPrefixOf "--" l || l == ""         = ImportSection start lastImportLine+  | otherwise                              = Res start lastImportLine+step (Res start end) _ = Res start end++moduleParse :: [Text] -> Either String P.Module+moduleParse t = first show $ do+  tokens <- (P.lex "" . T.unpack . T.unlines) t+  P.runTokenParser "<psc-ide>" P.parseModule tokens++-- | Adds an implicit import like @import Prelude@ to a Sourcefile.+addImplicitImport :: (MonadIO m, MonadError PscIdeError m)+                     => FilePath     -- ^ The Sourcefile read from+                     -> P.ModuleName -- ^ The module to import+                     -> m [Text]+addImplicitImport fp mn = do+  (_, pre, imports, post) <- parseImportsFromFile fp+  let newImportSection = addImplicitImport' imports mn+  pure $ pre ++ newImportSection ++ post++addImplicitImport' :: [Import] -> P.ModuleName -> [Text]+addImplicitImport' imports mn =+  -- We need to append the new import, because there could already be implicit+  -- imports and we need to preserve the order on these, as the first implicit+  -- import is the one that doesn't generate warnings.+  prettyPrintImportSection ( imports ++ [Import mn P.Implicit Nothing])++-- | Adds an explicit import like @import Prelude (unit)@ to a Sourcefile. If an+-- explicit import already exists for the given module, it adds the identifier+-- to that imports list.+--+-- So @addExplicitImport "/File.purs" "bind" "Prelude"@ with an already existing+-- @import Prelude (bind)@ in the file File.purs returns @["import Prelude+-- (bind, unit)"]@+addExplicitImport :: (MonadIO m, MonadError PscIdeError m, MonadLogger m) =>+                     FilePath -> ExternDecl -> P.ModuleName -> m [Text]+addExplicitImport fp decl moduleName = do+  (mn, pre, imports, post) <- parseImportsFromFile fp+  let newImportSection =+        -- TODO: Open an issue when this PR is merged, we should optimise this+        -- so that this case does not write to disc+        if mn == moduleName+        then imports+        else addExplicitImport' decl moduleName imports+  pure (pre ++ prettyPrintImportSection newImportSection ++ post)++addExplicitImport' :: ExternDecl -> P.ModuleName -> [Import] -> [Import]+addExplicitImport' decl moduleName imports =+  let+    isImplicitlyImported =+      not . null $ filter (\case+                              (Import mn P.Implicit Nothing) -> mn == moduleName+                              _ -> False) imports+    matches (Import mn (P.Explicit _) Nothing) = mn == moduleName+    matches _ = False+    freshImport = Import moduleName (P.Explicit [refFromDeclaration decl]) Nothing+  in+    if isImplicitlyImported+    then imports+    else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports+  where+    refFromDeclaration (TypeClassDeclaration n) = P.TypeClassRef n+    refFromDeclaration (DataConstructor n tn _) =+      P.TypeRef tn (Just [P.ProperName (T.unpack n)])+    refFromDeclaration (TypeDeclaration n _) = P.TypeRef n (Just [])+    refFromDeclaration d =+      let+        ident = T.unpack (identifierFromExternDecl d)+      in+        P.ValueRef ((if all P.isSymbolChar ident then P.Op else P.Ident) ident)++    -- | Adds a declaration to an import:+    -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe)+    insertDeclIntoImport :: ExternDecl -> Import -> Import+    insertDeclIntoImport decl' (Import mn (P.Explicit refs) Nothing) =+      Import mn (P.Explicit (insertDeclIntoRefs decl' refs)) Nothing+    insertDeclIntoImport _ is = is++    insertDeclIntoRefs :: ExternDecl -> [P.DeclarationRef] -> [P.DeclarationRef]+    insertDeclIntoRefs (DataConstructor dtor tn _) refs =+      let+        dtor' = P.ProperName (T.unpack dtor)+        -- TODO: Get rid of this once typeclasses can't be imported like types+        refs' = properRefToTypeRef <$> refs+      in+        updateAtFirstOrPrepend (matchType tn) (insertDtor dtor') (P.TypeRef tn (Just [dtor'])) refs'+    insertDeclIntoRefs dr refs = List.nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs)++    insertDtor dtor (P.TypeRef tn' dtors) =+      case dtors of+        Just dtors' -> P.TypeRef tn' (Just (List.nub (dtor : dtors')))+        -- This means the import was opened. We don't add anything in this case+        -- import Data.Maybe (Maybe(..)) -> import Data.Maybe (Maybe(Just))+        Nothing -> P.TypeRef tn' Nothing+    insertDtor _ refs = refs+++    -- TODO: Get rid of this once typeclasses can't be imported like types+    properRefToTypeRef (P.ProperRef n) = P.TypeRef (P.ProperName n) (Just [])+    properRefToTypeRef r = r++    matchType :: P.ProperName 'P.TypeName -> P.DeclarationRef -> Bool+    matchType tn (P.TypeRef n _) = tn == n+    matchType _ _ = False++updateAtFirstOrPrepend :: (a -> Bool) -> (a -> a) -> a -> [a] -> [a]+updateAtFirstOrPrepend p t d l =+  case List.findIndex p l of+    Nothing -> d : l+    Just ix ->+      let (x, a : y) = List.splitAt ix l+      in x ++ [t a] ++ y++-- | Looks up the given identifier in the currently loaded modules.+--+-- * Throws an error if the identifier cannot be found.+--+-- * If exactly one match is found, adds an explicit import to the importsection+--+-- * If more than one possible imports are found, reports the possibilities as a+-- list of completions.+addImportForIdentifier :: (PscIde m, MonadError PscIdeError m, MonadLogger m)+                          => FilePath -- ^ The Sourcefile to read from+                          -> Text     -- ^ The identifier to import+                          -> [Filter] -- ^ Filters to apply before searching for+                                      -- the identifier+                          -> m (Either [Match] [Text])+addImportForIdentifier fp ident filters = do+  modules <- getAllModulesWithReexports+  case getExactMatches ident filters modules of+    [] ->+      throwError (NotFound "Couldn't find the given identifier. \+                           \Have you loaded the corresponding module?")++    -- Only one match was found for the given identifier, so we can insert it+    -- right away+    [Match m decl] ->+      Right <$> addExplicitImport fp decl (P.moduleNameFromString (T.unpack m))++    -- This case comes up for newtypes and dataconstructors. Because values and+    -- types don't share a namespace we can get multiple matches from the same+    -- module. This also happens for parameterized types, as these generate both+    -- a type aswell as a type synonym.++    ms@[Match m1 d1, Match m2 d2] ->+      if m1 /= m2+         -- If the modules don't line up we just ask the user to specify the+         -- module+      then pure $ Left ms+      else case decideRedundantCase d1 d2 <|> decideRedundantCase d2 d1 of+        -- If dataconstructor and type line up we just import the+        -- dataconstructor as that will give us an unnecessary import warning at+        -- worst+        Just decl ->+          Right <$> addExplicitImport fp decl (P.moduleNameFromString (T.unpack m1))+        -- Here we need the user to specify whether he wanted a dataconstructor+        -- or a type+        Nothing ->+          throwError (GeneralError "Undecidable between type and dataconstructor")++    -- Multiple matches were found so we need to ask the user to clarify which+    -- module he meant+    xs ->+      pure $ Left xs+    where+      decideRedundantCase dtor@(DataConstructor _ t _) (TypeDeclaration t' _) =+        if t == t' then Just dtor else Nothing+      decideRedundantCase TypeDeclaration{} ts@TypeSynonymDeclaration{} =+        Just ts+      decideRedundantCase _ _ = Nothing++prettyPrintImport' :: Import -> Text+-- TODO: remove this clause once P.prettyPrintImport can properly handle PositionedRefs+prettyPrintImport' (Import mn (P.Explicit refs) qual) =+  T.pack $ "import " ++ P.prettyPrintImport mn (P.Explicit (unwrapPositionedRef <$> refs)) qual+prettyPrintImport' (Import mn idt qual) =+  T.pack $ "import " ++ P.prettyPrintImport mn idt qual++prettyPrintImportSection :: [Import] -> [Text]+prettyPrintImportSection imports = map prettyPrintImport' (List.sort imports)++-- | Writes a list of lines to @Just filepath@ and responds with a @TextResult@,+-- or returns the lines as a @MultilineTextResult@ if @Nothing@ was given as the+-- first argument.+answerRequest :: (MonadIO m) => Maybe FilePath -> [Text] -> m Success+answerRequest outfp rs  =+  case outfp of+    Nothing -> pure $ MultilineTextResult rs+    Just outfp' -> do+      liftIO $ TIO.writeFile outfp' (T.unlines rs)+      pure $ TextResult $ "Written to " <> T.pack outfp'++-- | Test and ghci helper+parseImport :: Text -> Maybe Import+parseImport t =+  case P.lex "<psc-ide>" (T.unpack t)+       >>= P.runTokenParser "<psc-ide>" P.parseImportDeclaration' of+    Right (mn, P.Explicit refs, mmn, _) ->+      Just (Import mn (P.Explicit (unwrapPositionedRef <$> refs)) mmn)+    Right (mn, idt, mmn, _) -> Just (Import mn idt mmn)+    Left _ -> Nothing+

src/Language/PureScript/Ide/Matcher.hs view

@@ -1,8 +1,27 @@+-----------------------------------------------------------------------------+--+-- Module      : Language.PureScript.Ide.Matcher+-- Description : Matchers for psc-ide commands+-- Copyright   : Christoph Hegemann 2016+-- License     : MIT (http://opensource.org/licenses/MIT)+--+-- Maintainer  : Christoph Hegemann <christoph.hegemann1337@gmail.com>+-- Stability   : experimental+--+-- |+-- Matchers for psc-ide commands+-----------------------------------------------------------------------------+ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE ScopedTypeVariables        #-}-module Language.PureScript.Ide.Matcher (Matcher, flexMatcher, runMatcher) where +module Language.PureScript.Ide.Matcher+       ( Matcher+       , flexMatcher+       , runMatcher+       ) where+ import           Prelude                       () import           Prelude.Compat @@ -16,13 +35,14 @@ import qualified Data.Text                     as T import qualified Data.Text.Encoding            as TE import           Language.PureScript.Ide.Types+import           Language.PureScript.Ide.Util import           Text.EditDistance import           Text.Regex.TDFA               ((=~))  -type ScoredCompletion = (Completion, Double)+type ScoredMatch = (Match, Double) -newtype Matcher = Matcher (Endo [Completion]) deriving(Monoid)+newtype Matcher = Matcher (Endo [Match]) deriving(Monoid)  instance FromJSON Matcher where   parseJSON = withObject "matcher" $ \o -> do@@ -41,42 +61,43 @@       Nothing -> return mempty  -- | Matches any occurence of the search string with intersections--- |--- | The scoring measures how far the matches span the string where--- | closer is better.--- | Examples:--- |   flMa matches flexMatcher. Score: 14.28--- |   sons matches sortCompletions. Score: 6.25+--+-- The scoring measures how far the matches span the string where+-- closer is better.+-- Examples:+--   flMa matches flexMatcher. Score: 14.28+--   sons matches sortCompletions. Score: 6.25 flexMatcher :: Text -> Matcher-flexMatcher pattern = mkMatcher (flexMatch pattern)+flexMatcher p = mkMatcher (flexMatch p)  distanceMatcher :: Text -> Int -> Matcher distanceMatcher q maxDist = mkMatcher (distanceMatcher' q maxDist) -distanceMatcher' :: Text -> Int -> [Completion] -> [ScoredCompletion]+distanceMatcher' :: Text -> Int -> [Match] -> [ScoredMatch] distanceMatcher' q maxDist = mapMaybe go   where-    go c@(Completion (_, y, _)) = let d = dist (T.unpack y)-                                  in if d <= maxDist-                                     then Just (c, 1 / fromIntegral d)-                                     else Nothing+    go m = let d = dist (T.unpack y)+               y = identifierFromMatch m+          in if d <= maxDist+             then Just (m, 1 / fromIntegral d)+             else Nothing     dist = levenshteinDistance defaultEditCosts (T.unpack q) -mkMatcher :: ([Completion] -> [ScoredCompletion]) -> Matcher+mkMatcher :: ([Match] -> [ScoredMatch]) -> Matcher mkMatcher matcher = Matcher . Endo  $ fmap fst . sortCompletions . matcher -runMatcher :: Matcher -> [Completion] -> [Completion]+runMatcher :: Matcher -> [Match] -> [Match] runMatcher (Matcher m)= appEndo m -sortCompletions :: [ScoredCompletion] -> [ScoredCompletion]+sortCompletions :: [ScoredMatch] -> [ScoredMatch] sortCompletions = sortBy (flip compare `on` snd) -flexMatch :: Text -> [Completion] -> [ScoredCompletion]-flexMatch pattern = mapMaybe (flexRate pattern)+flexMatch :: Text -> [Match] -> [ScoredMatch]+flexMatch = mapMaybe . flexRate -flexRate :: Text -> Completion -> Maybe ScoredCompletion-flexRate pattern c@(Completion (_,ident,_)) = do-  score <- flexScore pattern ident+flexRate :: Text -> Match -> Maybe ScoredMatch+flexRate p c = do+  score <- flexScore p (identifierFromMatch c)   return (c, score)  -- FlexMatching ala Sublime.@@ -89,13 +110,13 @@ flexScore pat str =   case T.uncons pat of     Nothing -> Nothing-    Just (first, pattern) ->+    Just (first, p) ->       case TE.encodeUtf8 str =~ TE.encodeUtf8 pat' :: (Int, Int) of         (-1,0) -> Nothing         (start,len) -> Just $ calcScore start (start + len)       where         escapedPattern :: [Text]-        escapedPattern = map escape (T.unpack pattern)+        escapedPattern = map escape (T.unpack p)          -- escape prepends a backslash to "regexy" characters to prevent the         -- matcher from crashing when trying to build the regex

src/Language/PureScript/Ide/Pursuit.hs view

@@ -1,3 +1,17 @@+-----------------------------------------------------------------------------+--+-- Module      : Language.PureScript.Ide.Pursuit+-- Description : Pursuit client for psc-ide+-- Copyright   : Christoph Hegemann 2016+-- License     : MIT (http://opensource.org/licenses/MIT)+--+-- Maintainer  : Christoph Hegemann <christoph.hegemann1337@gmail.com>+-- Stability   : experimental+--+-- |+-- Pursuit client for psc-ide+-----------------------------------------------------------------------------+ {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-}

src/Language/PureScript/Ide/Reexports.hs view

@@ -1,6 +1,22 @@+-----------------------------------------------------------------------------+--+-- Module      : Language.PureScript.Ide.Reexports+-- Description : Resolves reexports for psc-ide+-- Copyright   : Christoph Hegemann 2016+--               Brian Sermons 2016+-- License     : MIT (http://opensource.org/licenses/MIT)+--+-- Maintainer  : Christoph Hegemann <christoph.hegemann1337@gmail.com>+-- Stability   : experimental+--+-- |+-- Resolves reexports for psc-ide+-----------------------------------------------------------------------------+ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards     #-} {-# LANGUAGE TupleSections     #-}+ module Language.PureScript.Ide.Reexports where

src/Language/PureScript/Ide/SourceFile.hs view

@@ -1,6 +1,21 @@+-----------------------------------------------------------------------------+--+-- Module      : Language.PureScript.Ide.SourceFile+-- Description : Getting declarations from PureScript sourcefiles+-- Copyright   : Christoph Hegemann 2016+-- License     : MIT (http://opensource.org/licenses/MIT)+--+-- Maintainer  : Christoph Hegemann <christoph.hegemann1337@gmail.com>+-- Stability   : experimental+--+-- |+-- Getting declarations from PureScript sourcefiles+-----------------------------------------------------------------------------+ {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings     #-}+ module Language.PureScript.Ide.SourceFile where  import           Prelude@@ -69,7 +84,7 @@ getPositionedImports (D.Module _ _ _ declarations _) =   mapMaybe isImport declarations   where-    isImport i@(D.PositionedDeclaration _ _ (D.ImportDeclaration{})) = Just i+    isImport i@(D.PositionedDeclaration _ _ D.ImportDeclaration{}) = Just i     isImport _ = Nothing  getDeclPosition :: D.Module -> String -> Maybe SP.SourceSpan

src/Language/PureScript/Ide/State.hs view

@@ -1,3 +1,17 @@+-----------------------------------------------------------------------------+--+-- Module      : Language.PureScript.Ide.State+-- Description : Functions to access psc-ide's state+-- Copyright   : Christoph Hegemann 2016+-- License     : MIT (http://opensource.org/licenses/MIT)+--+-- Maintainer  : Christoph Hegemann <christoph.hegemann1337@gmail.com>+-- Stability   : experimental+--+-- |+-- Functions to access psc-ide's state+-----------------------------------------------------------------------------+ {-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -68,12 +82,13 @@ insertModule externsFile = do   env <- ask   let moduleName = efModuleName externsFile-  $(logDebug) $ "Inserting Module: " <> (T.pack (runModuleName moduleName))+  $(logDebug) $ "Inserting Module: " <> T.pack (runModuleName moduleName)   liftIO . atomically $ insertModule' (envStateVar env) externsFile  insertModule' :: TVar PscIdeState -> ExternsFile -> STM ()-insertModule' st ef = modifyTVar st $ \x ->-                      x { externsFiles = M.insert (efModuleName ef) ef (externsFiles x)-                        , pscStateModules = let (mn, decls) = convertExterns ef-                                            in M.insert mn decls (pscStateModules x)-                        }+insertModule' st ef =+    modifyTVar st $ \x ->+      x { externsFiles = M.insert (efModuleName ef) ef (externsFiles x)+        , pscStateModules = let (mn, decls) = convertExterns ef+                            in M.insert mn decls (pscStateModules x)+        }

src/Language/PureScript/Ide/Types.hs view

@@ -1,3 +1,17 @@+-----------------------------------------------------------------------------+--+-- Module      : Language.PureScript.Ide.Types+-- Description : Type definitions for psc-ide+-- Copyright   : Christoph Hegemann 2016+-- License     : MIT (http://opensource.org/licenses/MIT)+--+-- Maintainer  : Christoph Hegemann <christoph.hegemann1337@gmail.com>+-- Stability   : experimental+--+-- |+-- Type definitions for psc-ide+-----------------------------------------------------------------------------+ {-# LANGUAGE ConstraintKinds            #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -19,51 +33,40 @@ import           Data.Text                            (Text (), pack, unpack) import qualified Language.PureScript.AST.Declarations as D import           Language.PureScript.Externs-import           Language.PureScript.Names import qualified Language.PureScript.Names            as N+import qualified Language.PureScript as P  import           Text.Parsec import           Text.Parsec.Text +type Ident = Text+type DeclIdent = Text type ModuleIdent = Text-type DeclIdent   = Text-type Type        = Text -data Fixity = Infix | Infixl | Infixr deriving(Show, Eq, Ord)- data ExternDecl     -- | A function/value declaration-    = FunctionDecl-        DeclIdent -- The functions name-        Type      -- The functions type-    | FixityDeclaration Fixity Int DeclIdent+    = ValueDeclaration Ident P.Type+    | TypeDeclaration (P.ProperName 'P.TypeName) P.Kind+    | TypeSynonymDeclaration (P.ProperName 'P.TypeName) P.Type     -- | A Dependency onto another Module     | Dependency         ModuleIdent  -- name of the dependency         [Text]       -- explicit imports         (Maybe Text) -- An eventual qualifier-     -- | A module declaration     | ModuleDecl         ModuleIdent -- The modules name         [DeclIdent] -- The exported identifiers     -- | A data/newtype declaration-    | DataDecl DeclIdent -- The type name-               Text      -- The "type"+    | DataConstructor+      DeclIdent -- ^ The type name+      (P.ProperName 'P.TypeName)+      P.Type      -- ^ The "type"     -- | An exported module+    | TypeClassDeclaration (P.ProperName 'P.ClassName)     | Export ModuleIdent -- The exported Modules name     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 Configuration =@@ -83,16 +86,23 @@ data PscIdeState =   PscIdeState   { pscStateModules :: M.Map Text [ExternDecl]-  , externsFiles    :: M.Map ModuleName ExternsFile+  , externsFiles    :: M.Map P.ModuleName ExternsFile   } deriving Show  emptyPscIdeState :: PscIdeState emptyPscIdeState = PscIdeState M.empty M.empty +data Match = Match ModuleIdent ExternDecl+               deriving (Show, Eq)+ newtype Completion =-    Completion (ModuleIdent, DeclIdent, Type)-    deriving (Show,Eq)+  Completion (ModuleIdent, DeclIdent, Text)+  deriving (Show,Eq) +instance ToJSON Completion where+  toJSON (Completion (m,d,t)) =+    object ["module" .= m, "identifier" .= d, "type" .= t]+ data ModuleImport =   ModuleImport   { importModuleName :: ModuleIdent@@ -127,18 +137,6 @@ 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"-    pure (Completion (m, d, t))-  parseJSON _ = mzero--instance ToJSON Completion where-  toJSON (Completion (m,d,t)) =-    object ["module" .= m, "identifier" .= d, "type" .= t]- data Success =   CompletionResult [Completion]   | TextResult Text@@ -174,7 +172,7 @@   parseJSON _ = mzero  instance FromJSON PursuitQuery where-  parseJSON o = PursuitQuery <$> (parseJSON o)+  parseJSON o = PursuitQuery <$> parseJSON o  data PursuitResponse =   -- | A Pursuit Response for a module. Consists of the modules name and the@@ -182,7 +180,7 @@   ModuleResponse ModuleIdent Text   -- | A Pursuit Response for a declaration. Consist of the declarations type,   -- module, name and package-  | DeclarationResponse Type ModuleIdent DeclIdent Text+  | DeclarationResponse Text ModuleIdent DeclIdent Text   deriving (Show,Eq)  instance FromJSON PursuitResponse where@@ -215,15 +213,15 @@       type' <- many1 anyChar       pure (unpack name, type') -identifier :: Parser Text-identifier = do-  spaces-  ident <--    -- necessary for being able to parse the following ((++), concat)-    between (char '(') (char ')') (many1 (noneOf ", )")) <|>-    many1 (noneOf ", )")-  spaces-  pure (pack ident)+    identifier :: Parser Text+    identifier = do+      spaces+      ident <-+        -- necessary for being able to parse the following ((++), concat)+        between (char '(') (char ')') (many1 (noneOf ", )")) <|>+        many1 (noneOf ", )")+      spaces+      pure (pack ident)  instance ToJSON PursuitResponse where   toJSON (ModuleResponse name package) =

+ src/Language/PureScript/Ide/Util.hs view

@@ -0,0 +1,65 @@+-----------------------------------------------------------------------------+--+-- Module      : Language.PureScript.Ide.Util+-- Description : Generally useful functions and conversions+-- Copyright   : Christoph Hegemann 2016+-- License     : MIT (http://opensource.org/licenses/MIT)+--+-- Maintainer  : Christoph Hegemann <christoph.hegemann1337@gmail.com>+-- Stability   : experimental+--+-- |+-- Generally useful functions and conversions+-----------------------------------------------------------------------------++{-# LANGUAGE OverloadedStrings #-}++module Language.PureScript.Ide.Util where++import           Data.Aeson+import           Data.Text                     (Text)+import qualified Data.Text                     as T+import           Data.Text.Lazy                (fromStrict, toStrict)+import           Data.Text.Lazy.Encoding       (decodeUtf8, encodeUtf8)+import qualified Language.PureScript           as P+import           Language.PureScript.Ide.Types++runProperNameT :: P.ProperName a -> Text+runProperNameT = T.pack . P.runProperName++runIdentT :: P.Ident -> Text+runIdentT = T.pack . P.runIdent++prettyTypeT :: P.Type -> Text+prettyTypeT = T.unwords . fmap T.strip . T.lines . T.pack . P.prettyPrintType++identifierFromExternDecl :: ExternDecl -> Text+identifierFromExternDecl (ValueDeclaration name _) = name+identifierFromExternDecl (TypeDeclaration name _) = runProperNameT name+identifierFromExternDecl (TypeSynonymDeclaration name _) = runProperNameT name+identifierFromExternDecl (DataConstructor name _ _) = name+identifierFromExternDecl (TypeClassDeclaration name) = runProperNameT name+identifierFromExternDecl (ModuleDecl name _) = name+identifierFromExternDecl Dependency{} = "~Dependency~"+identifierFromExternDecl Export{} = "~Export~"++identifierFromMatch :: Match -> Text+identifierFromMatch (Match _ ed) = identifierFromExternDecl ed++completionFromMatch :: Match -> Maybe Completion+completionFromMatch (Match _ Dependency{}) = Nothing+completionFromMatch (Match _ Export{}) = Nothing+completionFromMatch (Match m d) = Just $ case d of+  ValueDeclaration name type' -> Completion (m, name, prettyTypeT type')+  TypeDeclaration name kind -> Completion (m, runProperNameT name, T.pack $ P.prettyPrintKind kind)+  TypeSynonymDeclaration name kind -> Completion (m, runProperNameT name, prettyTypeT kind)+  DataConstructor name _ type' -> Completion (m, name, prettyTypeT type')+  TypeClassDeclaration name -> Completion (m, runProperNameT name, "class")+  ModuleDecl name _ -> Completion ("module", name, "module")+  _ -> error "the impossible happened in completionFromMatch"++encodeT :: (ToJSON a) => a -> Text+encodeT = toStrict . decodeUtf8 . encode++decodeT :: (FromJSON a) => Text -> Maybe a+decodeT = decode . encodeUtf8 . fromStrict

src/Language/PureScript/Ide/Watcher.hs view

@@ -1,4 +1,19 @@+-----------------------------------------------------------------------------+--+-- Module      : Language.PureScript.Ide.Watcher+-- Description : File watcher for externs files+-- Copyright   : Christoph Hegemann 2016+-- License     : MIT (http://opensource.org/licenses/MIT)+--+-- Maintainer  : Christoph Hegemann <christoph.hegemann1337@gmail.com>+-- Stability   : experimental+--+-- |+-- File watcher for externs files+-----------------------------------------------------------------------------+ {-# LANGUAGE RecordWildCards #-}+ module Language.PureScript.Ide.Watcher where  import           Prelude                         ()

src/Language/PureScript/Make.hs view

@@ -25,6 +25,7 @@ import Prelude () import Prelude.Compat +import Control.Applicative ((<|>)) import Control.Monad hiding (sequence) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(..))@@ -52,6 +53,8 @@ import qualified Data.Set as S import qualified Data.Map as M +import qualified Text.Parsec as Parsec+ import SourceMap.Types import SourceMap @@ -61,6 +64,8 @@ import System.IO.Error (tryIOError) import System.IO.UTF8 (readUTF8File, writeUTF8File) +import qualified Language.JavaScript.Parser as JS+ import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Externs@@ -76,6 +81,8 @@ import Language.PureScript.Sugar import Language.PureScript.TypeChecker import qualified Language.PureScript.Constants as C+import qualified Language.PureScript.Bundle as Bundle+import qualified Language.PureScript.Parser as PSParser  import qualified Language.PureScript.CodeGen.JS as J import qualified Language.PureScript.CoreFn as CF@@ -331,7 +338,9 @@         | not $ requiresForeign m -> do             tell $ errorMessage $ UnnecessaryFFIModule mn path             return Nothing-        | otherwise -> return $ Just $ J.JSApp Nothing (J.JSVar Nothing "require") [J.JSStringLiteral Nothing "./foreign"]+        | otherwise -> do+            checkForeignDecls m path+            return $ Just $ J.JSApp Nothing (J.JSVar Nothing "require") [J.JSStringLiteral Nothing "./foreign"]       Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn               | otherwise -> return Nothing     rawJs <- J.moduleToJs m foreignInclude@@ -384,9 +393,6 @@     exists <- doesFileExist path     traverse (const $ getModificationTime path) $ guard exists -  readTextFile :: FilePath -> Make String-  readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path-   writeTextFile :: FilePath -> String -> Make ()   writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do     mkdirp path@@ -397,3 +403,50 @@    progress :: ProgressMessage -> Make ()   progress = liftIO . putStrLn . renderProgressMessage++readTextFile :: FilePath -> Make String+readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path++-- |+-- Check that the declarations in a given PureScript module match with those+-- in its corresponding foreign module.+--+checkForeignDecls :: CF.Module ann -> FilePath -> SupplyT Make ()+checkForeignDecls m path = do+  jsStr <- lift $ readTextFile path+  js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse jsStr path++  foreignIdentsStrs <- either errorParsingModule pure $ getExps js+  let foreignIdents =+        either+          (internalError . ("checkForeignDecls: unexpected idents: " ++) . show)+          S.fromList+          (traverse parseIdent foreignIdentsStrs)+  let importedIdents = S.fromList $ map fst (CF.moduleForeign m)++  let unusedFFI = foreignIdents S.\\ importedIdents+  unless (null unusedFFI) $+    tell . errorMessage . UnusedFFIImplementations mname $+      S.toList unusedFFI++  let missingFFI = importedIdents S.\\ foreignIdents+  unless (null missingFFI) $+    throwError . errorMessage . MissingFFIImplementations mname $+      S.toList missingFFI++  where+  mname = CF.moduleName m++  errorParsingModule :: Bundle.ErrorMessage -> SupplyT Make a+  errorParsingModule = throwError . errorMessage . ErrorParsingFFIModule path . Just++  getExps :: JS.JSAST -> Either Bundle.ErrorMessage [String]+  getExps = Bundle.getExportedIdentifiers (runModuleName mname)++  -- TODO: Handling for parenthesised operators should be removed after 0.9.+  parseIdent :: String -> Either String Ident+  parseIdent str = try str <|> try ("(" ++ str ++ ")")+    where+    try s = either (Left . show) Right $ do+      ts <- PSParser.lex "" s+      PSParser.runTokenParser "" (PSParser.parseIdent <* Parsec.eof) ts

src/Language/PureScript/Parser/JS.hs view

@@ -43,7 +43,7 @@   foreigns <- parU files $ \(path, file) ->     case findModuleName (lines file) of       Just name -> return (name, path)-      Nothing -> throwError (errorMessage $ ErrorParsingFFIModule path)+      Nothing -> throwError (errorMessage $ ErrorParsingFFIModule path Nothing)   let grouped = groupBy ((==) `on` fst) $ sortBy (compare `on` fst) foreigns   forM_ grouped $ \grp ->     when (length grp > 1) $ do

src/Language/PureScript/TypeChecker.hs view

@@ -234,7 +234,7 @@   go (ValueDeclaration name nameKind [] (Right val)) =     warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do       valueIsNotDefined moduleName name-      [(_, (val', ty))] <- typesOf moduleName [(name, val)]+      [(_, (val', ty))] <- typesOf NonRecursiveBindingGroup moduleName [(name, val)]       addValue moduleName name ty nameKind       return $ ValueDeclaration name nameKind [] $ Right val'   go ValueDeclaration{} = internalError "Binders were not desugared"@@ -242,7 +242,7 @@     warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do       for_ (map (\(ident, _, _) -> ident) vals) $ \name ->         valueIsNotDefined moduleName name-      tys <- typesOf moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals+      tys <- typesOf RecursiveBindingGroup moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals       vals' <- forM [ (name, val, nameKind, ty)                     | (name, nameKind, _) <- vals                     , (name', (val, ty)) <- tys

src/Language/PureScript/TypeChecker/Types.hs view

@@ -7,9 +7,10 @@ -- | -- This module implements the type checker ---module Language.PureScript.TypeChecker.Types (-    typesOf-) where+module Language.PureScript.TypeChecker.Types+  ( BindingGroupType(..)+  , typesOf+  ) where  {-   The following functions represent the corresponding type checking judgements:@@ -59,14 +60,20 @@ import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types +data BindingGroupType+  = RecursiveBindingGroup+  | NonRecursiveBindingGroup+  deriving (Show, Eq, Ord)+ -- | Infer the types of multiple mutually-recursive values, and return elaborated values including -- type class dictionaries and type annotations. typesOf ::   (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>+  BindingGroupType ->   ModuleName ->   [(Ident, Expr)] ->   m [(Ident, (Expr, Type))]-typesOf moduleName vals = do+typesOf bindingGroupType moduleName vals = do   tys <- fmap tidyUp . liftUnifyWarnings replace $ do     (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals     ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict@@ -79,14 +86,23 @@     let unsolvedTypeVars = nub $ unknownsInType ty     -- Generalize and constrain the type     let generalized = generalize unsolved ty-    -- Make sure any unsolved type constraints only use type variables which appear-    -- unknown in the inferred type.+     when shouldGeneralize $ do+      -- Show the inferred type in a warning       tell . errorMessage $ MissingTypeDeclaration ident generalized+      -- For non-recursive binding groups, can generalize over constraints.+      -- For recursive binding groups, we throw an error here for now.+      when (bindingGroupType == RecursiveBindingGroup && not (null unsolved))+        . throwError+        . errorMessage+        $ CannotGeneralizeRecursiveFunction ident generalized+      -- Make sure any unsolved type constraints only use type variables which appear+      -- unknown in the inferred type.       forM_ unsolved $ \(_, (className, classTys)) -> do         let constraintTypeVars = nub $ foldMap unknownsInType classTys         when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $           throwError . errorMessage $ NoInstanceFound className classTys+     -- Check skolem variables did not escape their scope     skolemEscapeCheck val'     -- Check rows do not contain duplicate labels@@ -179,7 +195,7 @@   g (TypedValue checkTy val t) = TypedValue checkTy val (f t)   g (TypeClassDictionary (nm, tys) sco) = TypeClassDictionary (nm, map f tys) sco   g other = other-  + -- | Check the kind of a type, failing if it is not of kind *. checkTypeKind ::   (MonadState CheckState m, MonadError MultipleErrors m) =>@@ -283,8 +299,10 @@   cond' <- check cond tyBoolean   th'@(TypedValue _ _ thTy) <- infer th   el'@(TypedValue _ _ elTy) <- infer el-  unifyTypes thTy elTy-  return $ TypedValue True (IfThenElse cond' th' el') thTy+  (th'', thTy') <- instantiatePolyTypeWithUnknowns th' thTy+  (el'', elTy') <- instantiatePolyTypeWithUnknowns el' elTy+  unifyTypes thTy' elTy'+  return $ TypedValue True (IfThenElse cond' th'' el'') thTy' infer' (Let ds val) = do   (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer   return $ TypedValue True (Let ds' val') valTy

stack-lts-5.yaml view

@@ -3,4 +3,5 @@ - '.' extra-deps: - bower-json-0.8.0+- language-javascript-0.6.0.4 flags: {}

stack-nightly.yaml view

@@ -1,5 +1,6 @@ flags: {} packages: - '.'-extra-deps: []+extra-deps: +- language-javascript-0.6.0.4 resolver: nightly-2016-03-17

stack.yaml view

@@ -3,4 +3,5 @@ - '.' extra-deps: - bower-json-0.8.0+- language-javascript-0.6.0.4 flags: {}

+ tests/Language/PureScript/Ide/FilterSpec.hs view

@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}+module Language.PureScript.Ide.FilterSpec where++import           Data.Text                      (Text)+import           Language.PureScript.Ide.Filter+import           Language.PureScript.Ide.Types+import qualified Language.PureScript as P+import           Test.Hspec++value :: Text -> ExternDecl+value s = ValueDeclaration s P.TypeWildcard++modules :: [Module]+modules =+  [+    ("Module.A", [value "function1"]),+    ("Module.B", [value "data1"]),+    ("Module.C", [ModuleDecl "Module.C" []]),+    ("Module.D", [Dependency "Module.C" [] Nothing, value "asd"])+  ]++runEq :: Text -> [Module]+runEq s = runFilter (equalityFilter s) modules+runPrefix :: Text -> [Module]+runPrefix s = runFilter (prefixFilter s) modules+runModule :: [ModuleIdent] -> [Module]+runModule ms = runFilter (moduleFilter ms) modules+runDependency :: [ModuleIdent] -> [Module]+runDependency ms = runFilter (dependencyFilter ms) modules++spec :: Spec+spec = do+  describe "equality Filter" $ do+    it "removes empty modules" $+      runEq "test" `shouldBe` []+    it "keeps function declarations that are equal" $+      runEq "function1" `shouldBe` [head modules]+    -- TODO: It would be more sensible to match Constructors+    it "keeps data declarations that are equal" $+      runEq "data1" `shouldBe` [modules !! 1]+  describe "prefixFilter" $ do+    it "keeps everything on empty string" $+      runPrefix "" `shouldBe` modules+    it "keeps functionname prefix matches" $+      runPrefix "fun" `shouldBe` [head modules]+    it "keeps data decls prefix matches" $+      runPrefix "dat" `shouldBe` [modules !! 1]+    it "keeps module decl prefix matches" $+      runPrefix "Mod" `shouldBe` [modules !! 2]+  describe "moduleFilter" $ do+    it "removes everything on empty input" $+      runModule [] `shouldBe` []+    it "only keeps the specified modules" $+      runModule ["Module.A", "Module.C"] `shouldBe` [head modules, modules !! 2]+    it "ignores modules that are not in scope" $+      runModule ["Module.A", "Module.C", "Unknown"] `shouldBe` [head modules, modules !! 2]+  describe "dependencyFilter" $ do+    it "removes everything on empty input" $+      runDependency [] `shouldBe` []+    it "only keeps the specified modules if they have no imports" $+      runDependency ["Module.A", "Module.B"] `shouldBe` [head modules, modules !! 1]+    it "keeps the specified modules and their imports" $+      runDependency ["Module.A", "Module.D"] `shouldBe` [head modules, modules !! 2, modules !! 3]

+ tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs view

@@ -0,0 +1,101 @@+{-# LANGUAGE OverloadedStrings #-}+module Language.PureScript.Ide.Imports.IntegrationSpec where++import           Control.Monad+import           Data.Text                           (Text)+import qualified Data.Text                           as T+import qualified Data.Text.IO                        as TIO+import qualified Language.PureScript.Ide.Integration as Integration+import           Test.Hspec++import           System.Directory+import           System.FilePath++setup :: IO ()+setup = do+  Integration.deleteOutputFolder+  s <- Integration.compileTestProject+  unless s $ fail "Failed to compile .purs sources"+  Integration.quitServer -- kill a eventually running psc-ide-server instance+  _ <- Integration.startServer+  mapM_ Integration.loadModuleWithDeps ["ImportsSpec", "ImportsSpec1"]++teardown :: IO ()+teardown = Integration.quitServer++withSupportFiles :: (FilePath -> FilePath -> IO a) -> IO ()+withSupportFiles test = do+  pdir <- Integration.projectDirectory+  let sourceFp = pdir </> "src" </> "ImportsSpec.purs"+      outFp = pdir </> "src" </> "ImportsSpecOut.tmp"+  Integration.deleteFileIfExists outFp+  void $ test sourceFp outFp++outputFileShouldBe :: [Text] -> IO ()+outputFileShouldBe expectation = do+  outFp <- (</> "src" </> "ImportsSpecOut.tmp") <$> Integration.projectDirectory+  outRes <- TIO.readFile outFp+  shouldBe (T.lines outRes) expectation++spec :: Spec+spec = beforeAll_ setup $ afterAll_ teardown $ describe "Adding imports" $ do+  let+    sourceFileSkeleton :: [Text] -> [Text]+    sourceFileSkeleton importSection =+      [ "module ImportsSpec where" , ""] ++ importSection ++ [ "" , "myId = id"]+  it "adds an implicit import" $ do+    withSupportFiles (Integration.addImplicitImport "Prelude")+    outputFileShouldBe (sourceFileSkeleton+                        [ "import Prelude"+                        , "import Main (id)"+                        ])+  it "adds an explicit unqualified import" $ do+    withSupportFiles (Integration.addImport "exportedFunction")+    outputFileShouldBe (sourceFileSkeleton+                        [ "import ImportsSpec1 (exportedFunction)"+                        , "import Main (id)"+                        ])+  it "adds an explicit unqualified import (type)" $ do+    withSupportFiles (Integration.addImport "MyType")+    outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (MyType)"+                                           , "import Main (id)"+                                           ])+  it "adds an explicit unqualified import (parameterized type)" $ do+    withSupportFiles (Integration.addImport "MyParamType")+    outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (MyParamType)"+                                           , "import Main (id)"+                                           ])+  it "adds an explicit unqualified import (typeclass)" $ do+    withSupportFiles (Integration.addImport "ATypeClass")+    outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (class ATypeClass)"+                                           , "import Main (id)"])+  it "adds an explicit unqualified import (dataconstructor)" $ do+    withSupportFiles (Integration.addImport "MyJust")+    outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (MyMaybe(MyJust))"+                                           , "import Main (id)"])+  it "adds an explicit unqualified import (newtype)" $ do+    withSupportFiles (Integration.addImport "MyNewtype")+    outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (MyNewtype(MyNewtype))"+                                           , "import Main (id)"])+  it "adds an explicit unqualified import (typeclass member function)" $ do+    withSupportFiles (Integration.addImport "typeClassFun")+    outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (typeClassFun)"+                                           , "import Main (id)"])+  it "doesn't add a newtypes constructor if only the type is exported" $ do+    withSupportFiles (Integration.addImport "OnlyTypeExported")+    outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (OnlyTypeExported)"+                                            , "import Main (id)"])+  it "doesn't add an import if the identifier is defined in the module itself" $ do+    withSupportFiles (Integration.addImport "myId")+    outputFileShouldBe (sourceFileSkeleton [ "import Main (id)"])+  it "responds with an error if it's undecidable whether we want a type or constructor" $+    withSupportFiles (\sourceFp outFp -> do+                         r <- Integration.addImport "SpecialCase" sourceFp outFp+                         shouldBe False (Integration.resultIsSuccess r)+                         shouldBe False =<< doesFileExist outFp)+  it "responds with an error if the identifier cannot be found and doesn't \+     \write to the output file" $+    withSupportFiles (\sourceFp outFp -> do+                         r <- Integration.addImport "doesntExist" sourceFp outFp+                         shouldBe False (Integration.resultIsSuccess r)+                         shouldBe False =<< doesFileExist outFp)

+ tests/Language/PureScript/Ide/ImportsSpec.hs view

@@ -0,0 +1,125 @@+{-# LANGUAGE OverloadedStrings #-}+module Language.PureScript.Ide.ImportsSpec where++import           Data.Maybe                      (fromJust)+import           Data.Text                       (Text)+import qualified Language.PureScript             as P+import           Language.PureScript.Ide.Imports+import           Language.PureScript.Ide.Types+import           Test.Hspec++simpleFile :: [Text]+simpleFile =+  [ "module Main where"+  , "import Prelude"+  , ""+  , "myFunc x y = x + y"+  ]++splitSimpleFile :: (P.ModuleName, [Text], [Import], [Text])+splitSimpleFile = fromRight $ sliceImportSection simpleFile+  where+    fromRight (Right r) = r+    fromRight (Left _) = error "fromRight"++withImports :: [Text] -> [Text]+withImports is =+  take 2 simpleFile ++ is ++ drop 2 simpleFile++testParseImport :: Text -> Import+testParseImport = fromJust . parseImport++preludeImport, arrayImport, listImport, consoleImport, maybeImport :: Import+preludeImport = testParseImport "import Prelude"+arrayImport = testParseImport "import Data.Array (head, cons)"+listImport = testParseImport "import Data.List as List"+consoleImport = testParseImport "import Control.Monad.Eff.Console (log) as Console"+maybeImport = testParseImport "import Data.Maybe (Maybe(Just))"++spec :: Spec+spec = do+  describe "determining the importsection" $ do+    let moduleSkeleton imports =+          Right (P.moduleNameFromString "Main", take 1 simpleFile, imports, drop 2 simpleFile)+    it "finds a simple import" $+      shouldBe (sliceImportSection simpleFile) (moduleSkeleton [preludeImport])++    it "allows multiline import statements" $+      shouldBe+        (sliceImportSection (withImports [ "import Data.Array (head,"+                                         , "                   cons)"+                                         ]))+        (moduleSkeleton [preludeImport, arrayImport])+  describe "pretty printing imports" $ do+    it "pretty prints a simple import" $+      shouldBe (prettyPrintImport' preludeImport) "import Prelude"+    it "pretty prints an explicit import" $+      shouldBe (prettyPrintImport' arrayImport) "import Data.Array (head, cons)"+    it "pretty prints a qualified import" $+      shouldBe (prettyPrintImport' listImport) "import Data.List as List"+    it "pretty prints a qualified explicit import" $+      shouldBe (prettyPrintImport' consoleImport) "import Control.Monad.Eff.Console (log) as Console"+    it "pretty prints an import with a datatype (and PositionedRef's for the dtors)" $+      shouldBe (prettyPrintImport' maybeImport) "import Data.Maybe (Maybe(Just))"++  describe "import commands" $ do+    let simpleFileImports = let (_, _, i, _) = splitSimpleFile in i+        addValueImport i mn is =+          prettyPrintImportSection (addExplicitImport' (ValueDeclaration i P.TypeWildcard) mn is)+        addDtorImport i t mn is =+          prettyPrintImportSection (addExplicitImport' (DataConstructor i t P.TypeWildcard) mn is)+    it "adds an implicit unqualified import" $+      shouldBe+        (addImplicitImport' simpleFileImports (P.moduleNameFromString "Data.Map"))+        [ "import Prelude"+        , "import Data.Map"+        ]+    it "adds an explicit unqualified import" $+      shouldBe+        (addValueImport "head" (P.moduleNameFromString "Data.Array") simpleFileImports)+        [ "import Prelude"+        , "import Data.Array (head)"+        ]+    it "doesn't add an import if the containing module is imported implicitly" $+      shouldBe+      (addValueImport "const" (P.moduleNameFromString "Prelude") simpleFileImports)+      ["import Prelude"]+    let Right (_, _, explicitImports, _) = sliceImportSection (withImports ["import Data.Array (tail)"])+    it "adds an identifier to an explicit import list" $+      shouldBe+        (addValueImport "head" (P.moduleNameFromString "Data.Array") explicitImports)+        [ "import Prelude"+        , "import Data.Array (head, tail)"+        ]+    it "adds an operator to an explicit import list" $+      shouldBe+        (addValueImport "<~>" (P.moduleNameFromString "Data.Array") explicitImports)+        [ "import Prelude"+        , "import Data.Array ((<~>), tail)"+        ]+    it "adds the type for a given DataConstructor" $+        shouldBe+          (addDtorImport "Just" (P.ProperName "Maybe") (P.moduleNameFromString "Data.Maybe") simpleFileImports)+          [ "import Prelude"+          , "import Data.Maybe (Maybe(Just))"+          ]+    it "adds a dataconstructor to an existing type import" $ do+      let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe)"])+      shouldBe+        (addDtorImport "Just" (P.ProperName "Maybe") (P.moduleNameFromString "Data.Maybe") typeImports)+        [ "import Prelude"+        , "import Data.Maybe (Maybe(Just))"+        ]+    it "doesn't add a dataconstructor to an existing type import with open dtors" $ do+      let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe(..))"])+      shouldBe+        (addDtorImport "Just" (P.ProperName "Maybe") (P.moduleNameFromString "Data.Maybe") typeImports)+        [ "import Prelude"+        , "import Data.Maybe (Maybe(..))"+        ]+    it "doesn't add an identifier to an explicit import list if it's already imported" $+      shouldBe+      (addValueImport "tail" (P.moduleNameFromString "Data.Array") explicitImports)+      [ "import Prelude"+      , "import Data.Array (tail)"+      ]

+ tests/Language/PureScript/Ide/Integration.hs view

@@ -0,0 +1,238 @@+-----------------------------------------------------------------------------+--+-- Module      : Language.PureScript.Ide.Integration+-- Description : A psc-ide client for use in integration tests+-- Copyright   : Christoph Hegemann 2016+-- License     : MIT (http://opensource.org/licenses/MIT)+--+-- Maintainer  : Christoph Hegemann <christoph.hegemann1337@gmail.com>+-- Stability   : experimental+--+-- |+-- A psc-ide client for use in integration tests+-----------------------------------------------------------------------------++{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Language.PureScript.Ide.Integration+       (+         -- managing the server process+         startServer+       , withServer+       , stopServer+       , quitServer+         -- util+       , compileTestProject+       , deleteOutputFolder+       , projectDirectory+       , deleteFileIfExists+         -- sending commands+       , loadModuleWithDeps+       , getFlexCompletions+       , getType+       , addImport+       , addImplicitImport+         -- checking results+       , resultIsSuccess+       , parseCompletions+       , parseTextResult+       ) where++import           Control.Concurrent                (threadDelay)+import           Control.Exception+import           Control.Monad                     (join, when)+import           Data.Aeson+import           Data.Aeson.Types+import qualified Data.ByteString.Lazy.UTF8         as BSL+import           Data.Either                       (isRight)+import           Data.Maybe                        (fromJust)+import qualified Data.Text                         as T+import qualified Data.Vector                       as V+import           Language.PureScript.Ide.Util+import           System.Directory+import           System.Exit+import           System.FilePath+import           System.Process++projectDirectory :: IO FilePath+projectDirectory = do+  cd <- getCurrentDirectory+  return $ cd </> "tests" </> "support" </> "pscide"++startServer :: IO ProcessHandle+startServer = do+  pdir <- projectDirectory+  (_, _, _, procHandle) <- createProcess $ (shell "psc-ide-server") {cwd=Just pdir}+  threadDelay 500000 -- give the server 500ms to start up+  return procHandle++stopServer :: ProcessHandle -> IO ()+stopServer = terminateProcess++withServer :: IO a -> IO a+withServer s = do+  _ <- startServer+  r <- s+  quitServer+  return r++-- project management utils++compileTestProject :: IO Bool+compileTestProject = do+  pdir <- projectDirectory+  (_, _, _, procHandle) <- createProcess $+    (shell $ "psc " ++ fileGlob) {cwd=Just pdir+                                 ,std_out=CreatePipe+                                 ,std_err=CreatePipe+                                 }+  isSuccess <$> waitForProcess procHandle++deleteOutputFolder :: IO ()+deleteOutputFolder = do+  odir <- fmap (</> "output") projectDirectory+  whenM (doesDirectoryExist odir) (removeDirectoryRecursive odir)++deleteFileIfExists :: FilePath -> IO ()+deleteFileIfExists fp = whenM (doesFileExist fp) (removeFile fp)++whenM :: Monad m => m Bool -> m () -> m ()+whenM p f = do+  x <- p+  when x f++isSuccess :: ExitCode -> Bool+isSuccess ExitSuccess = True+isSuccess (ExitFailure _) = False++fileGlob :: String+fileGlob = unwords+  [ "\"src/**/*.purs\""+  , "\"src/**/*.js\""+  , "\"bower_components/purescript-*/**/*.purs\""+  , "\"bower_components/purescript-*/**/*.js\""+  ]++-- Integration Testing API++sendCommand :: Value -> IO String+sendCommand v = readCreateProcess+  ((shell "psc-ide-client") { std_out=CreatePipe+                            , std_err=CreatePipe+                            })+  (T.unpack (encodeT v))++quitServer :: IO ()+quitServer = do+  let quitCommand = object ["command" .= ("quit" :: String)]+  _ <- try $ sendCommand quitCommand :: IO (Either SomeException String)+  return ()++loadModuleWithDeps :: String -> IO String+loadModuleWithDeps m = sendCommand $ load [] [m]++getFlexCompletions :: String -> IO [(String, String, String)]+getFlexCompletions q = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q)))++getType :: String -> IO [(String, String, String)]+getType q = parseCompletions <$> sendCommand (typeC q [])++addImport :: String -> FilePath -> FilePath -> IO String+addImport identifier fp outfp = sendCommand (addImportC identifier fp outfp)++addImplicitImport :: String -> FilePath -> FilePath -> IO String+addImplicitImport mn fp outfp = sendCommand (addImplicitImportC mn fp outfp)++-- Command Encoding++commandWrapper :: String -> Value -> Value+commandWrapper c p = object ["command" .= c, "params" .= p]++load :: [String] -> [String] -> Value+load ms ds = commandWrapper "load" (object ["modules" .= ms, "dependencies" .= ds])++typeC :: String -> [Value] -> Value+typeC q filters = commandWrapper "type" (object ["search" .= q, "filters" .= filters])++addImportC :: String -> FilePath -> FilePath -> Value+addImportC identifier = addImportW $+  object [ "importCommand" .= ("addImport" :: String)+         , "identifier" .= identifier+         ]++addImplicitImportC :: String -> FilePath -> FilePath -> Value+addImplicitImportC mn = addImportW $+  object [ "importCommand" .= ("addImplicitImport" :: String)+         , "module" .= mn+         ]++addImportW :: Value -> FilePath -> FilePath -> Value+addImportW importCommand fp outfp =+  commandWrapper "import" (object [ "file" .= fp+                                  , "outfile" .= outfp+                                  , "importCommand" .= importCommand+                                  ])+++completion :: [Value] -> Maybe Value -> Value+completion filters matcher =+  let+    matcher' = case matcher of+      Nothing -> []+      Just m -> ["matcher" .= m]+  in+    commandWrapper "complete" (object $ "filters" .= filters : matcher')++flexMatcher :: String -> Value+flexMatcher q = object [ "matcher" .= ("flex" :: String)+                       , "params" .= object ["search" .= q]+                       ]++-- Result parsing++unwrapResult :: Value -> Parser (Either String Value)+unwrapResult = withObject "result" $ \o -> do+  (rt :: String) <- o .: "resultType"+  case rt of+    "error" -> do+      res <- o .: "result"+      pure (Left res)+    "success" -> do+      res <- o .: "result"+      pure (Right res)+    _ -> fail "lol"++withResult :: (Value -> Parser a) -> Value -> Parser (Either String a)+withResult p v = do+  r <- unwrapResult v+  case r of+    Left err -> pure (Left err)+    Right res -> Right <$> p res++completionParser :: Value -> Parser [(String, String, String)]+completionParser = withArray "res" $ \cs ->+  mapM (withObject "completion" $ \o -> do+           ident <- o .: "identifier"+           module' <- o .: "module"+           ty <- o .: "type"+           pure (module', ident, ty)) (V.toList cs)++valueFromString :: String -> Value+valueFromString = fromJust . decode . BSL.fromString++resultIsSuccess :: String -> Bool+resultIsSuccess = isRight . join . parseEither unwrapResult . valueFromString++parseCompletions :: String -> [(String, String, String)]+parseCompletions s = fromJust $ do+  cs <- parseMaybe (withResult completionParser) (valueFromString s)+  case cs of+    Left _ -> error "Failed to parse completions"+    Right cs' -> pure cs'++parseTextResult :: String -> String+parseTextResult s = fromJust $ do+  r <- parseMaybe (withResult (withText "tr" pure)) (valueFromString s)+  case r of+    Left _ -> error "Failed to parse textResult"+    Right r' -> pure (T.unpack r')

+ tests/Language/PureScript/Ide/MatcherSpec.hs view

@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedStrings #-}++module Language.PureScript.Ide.MatcherSpec where++import           Data.Text                           (Text)+import           Language.PureScript.Ide.Integration+import           Language.PureScript.Ide.Matcher+import           Language.PureScript.Ide.Types+import qualified Language.PureScript as P+import           Test.Hspec++value :: Text -> ExternDecl+value s = ValueDeclaration s P.TypeWildcard++completions :: [Match]+completions = [+  Match "" $ value "firstResult",+  Match "" $ value "secondResult",+  Match "" $ value "fiult"+  ]++mkResult :: [Int] -> [Match]+mkResult = map (completions !!)++runFlex :: Text -> [Match]+runFlex s = runMatcher (flexMatcher s) completions++setup :: IO ()+setup = do+  deleteOutputFolder+  _ <- compileTestProject+  _ <- startServer+  _ <- loadModuleWithDeps "Main"+  return ()++teardown :: IO ()+teardown = quitServer++spec :: Spec+spec = do+  describe "Flex Matcher" $ do+    it "doesn't match on an empty string" $+       runFlex "" `shouldBe` []+    it "matches on equality" $+      runFlex "firstResult" `shouldBe` mkResult [0]+    it "scores short matches higher and sorts accordingly" $+      runFlex "filt" `shouldBe` mkResult [2, 0]++  beforeAll_ setup $ afterAll_ teardown $+    describe "Integration Tests: Flex Matcher" $ do+      it "doesn't match on an empty string" $ do+        cs <- getFlexCompletions ""+        cs `shouldBe` []+      it "matches on equality" $ do+        cs <- getFlexCompletions "const"+        cs `shouldBe` [("Main", "const", "forall a b. a -> b -> a")]

+ tests/Language/PureScript/Ide/ReexportsSpec.hs view

@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedStrings #-}+module Language.PureScript.Ide.ReexportsSpec where++import           Control.Exception                 (evaluate)+import           Data.List                         (sort)+import qualified Data.Map                          as Map+import           Language.PureScript.Ide.Reexports+import           Language.PureScript.Ide.Types+import qualified Language.PureScript as P+import           Test.Hspec++decl1 :: ExternDecl+decl1 = ValueDeclaration "filter" P.TypeWildcard+decl2 :: ExternDecl+decl2 = ValueDeclaration "map" P.TypeWildcard+decl3 :: ExternDecl+decl3 = ValueDeclaration "catMaybe" P.TypeWildcard+dep1 :: ExternDecl+dep1 = Dependency "Test.Foo" [] (Just "T")+dep2 :: ExternDecl+dep2 = Dependency "Test.Bar" [] (Just "T")++circularModule :: Module+circularModule = ("Circular", [Export "Circular"])++module1 :: Module+module1 = ("Module1", [Export "Module2", Export "Module3", decl1])++module2 :: Module+module2 = ("Module2", [decl2])++module3 :: Module+module3 = ("Module3", [decl3])++module4 :: Module+module4 = ("Module4", [Export "T", decl1, dep1, dep2])++result :: Module+result = ("Module1", [decl1, decl2, Export "Module3"])++db :: Map.Map ModuleIdent [ExternDecl]+db = Map.fromList [module1, module2, module3]++shouldBeEqualSorted :: Module -> Module -> Expectation+shouldBeEqualSorted (n1, d1) (n2, d2) = (n1, sort d1) `shouldBe` (n2, sort d2)++spec :: Spec+spec =+  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", [])++    it "replaces exported aliases with imported module" $+      getReexports module4 `shouldBe` [Export "Test.Foo", Export "Test.Bar"]

+ tests/Language/PureScript/IdeSpec.hs view

@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedStrings #-}++module Language.PureScript.IdeSpec where++import           Control.Concurrent.STM+import           Control.Monad.Reader+import           Data.List+import qualified Data.Map                      as Map+import           Language.PureScript.Ide+import           Language.PureScript.Ide.Types+import           Test.Hspec++testState :: PscIdeState+testState = PscIdeState (Map.fromList [("Data.Array", []), ("Control.Monad.Eff", [])]) Map.empty++defaultConfig :: Configuration+defaultConfig =+  Configuration+  {+    confOutputPath = "output/"+  , confDebug = False+  }++spec :: SpecWith ()+spec =+  describe "list" $+    describe "loadedModules" $ do+      it "returns an empty list when no modules are loaded" $ do+        st <- newTVarIO emptyPscIdeState+        result <- runReaderT printModules (PscIdeEnvironment st defaultConfig)+        result `shouldBe` ModuleList []+      it "returns the list of loaded modules" $ do+        st <- newTVarIO testState+        ModuleList result <- runReaderT printModules (PscIdeEnvironment st defaultConfig)+        sort result `shouldBe` sort ["Data.Array", "Control.Monad.Eff"]

tests/TestDocs.hs view

@@ -17,6 +17,7 @@  import qualified Language.PureScript as P import qualified Language.PureScript.Docs as Docs+import Language.PureScript.Docs.AsMarkdown (codeToString) import qualified Language.PureScript.Publish as Publish import qualified Language.PureScript.Publish.ErrorsWarnings as Publish @@ -59,6 +60,10 @@   -- | Assert that a particular value declaration exists, and its type   -- satisfies the given predicate.   | ValueShouldHaveTypeSignature P.ModuleName String (ShowFn (P.Type -> Bool))+  -- | Assert that a particular type alias exists, and its corresponding+  -- type, when rendered, matches a given string exactly+  -- fields: module, type synonym name, expected type+  | TypeSynonymShouldRenderAs P.ModuleName String String   deriving (Show)  newtype ShowFn a = ShowFn a@@ -85,6 +90,9 @@   -- should have been.   -- Fields: module name, declaration name, actual type.   | ValueDeclarationWrongType P.ModuleName String P.Type+  -- | A Type synonym has been rendered in an unexpected format+  -- Fields: module name, declaration name, expected rendering, actual rendering+  | TypeSynonymMismatch P.ModuleName String String String   deriving (Show)  data AssertionResult@@ -149,6 +157,21 @@               Fail (WrongDeclarationType mn decl "value"                      (Docs.declInfoToString declInfo)) +    TypeSynonymShouldRenderAs mn decl expected ->+      case find ((==) decl . Docs.declTitle) (declarationsFor mn) of+        Nothing ->+          Fail (NotDocumented mn decl)+        Just Docs.Declaration{..} ->+          case declInfo of+            Docs.TypeSynonymDeclaration [] ty ->+              let actual = codeToString (Docs.renderType ty) in+              if actual == expected+                 then Pass+                 else Fail (TypeSynonymMismatch mn decl expected actual)+            _ ->+              Fail (WrongDeclarationType mn decl "synonym"+                    (Docs.declInfoToString declInfo))+   where   declarationsFor mn =     if mn == modName@@ -261,6 +284,13 @@       , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt"    (ShowFn (P.tyInt ==))       , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber"  (ShowFn (P.tyNumber ==))       ])++    , ("ConstrainedArgument",+        [ TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithoutArgs" "forall a. (Partial => a) -> a"+        , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithArgs" "forall a. (Foo a => a) -> a"+        , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithoutArgs" "forall a. ((Partial, Partial) => a) -> a"+        , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithArgs" "forall a b. ((Foo a, Foo b) => a) -> a"+        ])   ]    where

+ tests/support/pscide/src/ImportsSpec.purs view

@@ -0,0 +1,5 @@+module ImportsSpec where++import Main (id)++myId = id

+ tests/support/pscide/src/ImportsSpec1.purs view

@@ -0,0 +1,32 @@+module ImportsSpec1+       ( exportedFunction+       , MyType+       , MyParamType+       , MyNewtype(..)+       , MyMaybe(..)+       , SpecialCase+       , X(..)+       , class ATypeClass+       , typeClassFun+       , OnlyTypeExported+       )+       where++exportedFunction ∷ ∀ a. a → a+exportedFunction x = x++type MyType = String++type MyParamType a = Array a++newtype MyNewtype = MyNewtype String++data MyMaybe a = MyJust a | MyNothing++data SpecialCase+data X = SpecialCase++newtype OnlyTypeExported = OnlyTypeExported String++class ATypeClass a where+  typeClassFun ∷ a -> a

+ tests/support/pscide/src/Main.purs view

@@ -0,0 +1,7 @@+module Main where++id :: forall a. a -> a+id x = x++const :: forall a b. a -> b -> a+const x _ = x