diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -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 diff --git a/examples/docs/src/ConstrainedArgument.purs b/examples/docs/src/ConstrainedArgument.purs new file mode 100644 --- /dev/null +++ b/examples/docs/src/ConstrainedArgument.purs @@ -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 + diff --git a/examples/failing/Generalization1.purs b/examples/failing/Generalization1.purs new file mode 100644 --- /dev/null +++ b/examples/failing/Generalization1.purs @@ -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 + diff --git a/examples/failing/Generalization2.purs b/examples/failing/Generalization2.purs new file mode 100644 --- /dev/null +++ b/examples/failing/Generalization2.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith CannotGeneralizeRecursiveFunction +module Main where + +import Prelude + +test n m | n <= 1 = m + | otherwise = test (n - 1) (m <> m) + diff --git a/examples/passing/1991.purs b/examples/passing/1991.purs new file mode 100644 --- /dev/null +++ b/examples/passing/1991.purs @@ -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" diff --git a/examples/passing/Generalization1.purs b/examples/passing/Generalization1.purs new file mode 100644 --- /dev/null +++ b/examples/passing/Generalization1.purs @@ -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 diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs --- a/psc-bundle/Main.hs +++ b/psc-bundle/Main.hs @@ -1,25 +1,12 @@ ------------------------------------------------------------------------------ --- --- Module : psc-bundle --- Copyright : (c) Phil Freeman 2015 --- License : MIT --- --- Maintainer : Phil Freeman --- 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) diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs --- a/psc-docs/Main.hs +++ b/psc-docs/Main.hs @@ -1,17 +1,4 @@ {-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- --- --- Module : Main --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- 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 diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs --- a/psc-ide-server/Main.hs +++ b/psc-ide-server/Main.hs @@ -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 +-- 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 diff --git a/psc-publish/Main.hs b/psc-publish/Main.hs --- a/psc-publish/Main.hs +++ b/psc-publish/Main.hs @@ -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 diff --git a/psc/Main.hs b/psc/Main.hs --- a/psc/Main.hs +++ b/psc/Main.hs @@ -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 --- 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 diff --git a/purescript.cabal b/purescript.cabal --- a/purescript.cabal +++ b/purescript.cabal @@ -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 diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -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 diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -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 diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -6,6 +6,7 @@ , Docs , runDocs , modulesAsMarkdown + , codeToString ) where import Prelude () diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs --- a/src/Language/PureScript/Docs/RenderedCode/Render.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs @@ -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] ] ] diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -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]) = diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -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 +-- 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 diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -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 +-- 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 "" s >>= runTokenParser "" (parseType <* P.eof) of + case P.lex "" s >>= P.runTokenParser "" (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'] diff --git a/src/Language/PureScript/Ide/CodecJSON.hs b/src/Language/PureScript/Ide/CodecJSON.hs deleted file mode 100644 --- a/src/Language/PureScript/Ide/CodecJSON.hs +++ /dev/null @@ -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 - diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -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 +-- 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 diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -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 diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -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 +-- 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 diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -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 +-- 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 diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -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 +-- 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 = diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Ide/Imports.hs @@ -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 +-- 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 "" 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 "" (T.unpack t) + >>= P.runTokenParser "" 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 + diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs --- a/src/Language/PureScript/Ide/Matcher.hs +++ b/src/Language/PureScript/Ide/Matcher.hs @@ -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 +-- 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 diff --git a/src/Language/PureScript/Ide/Pursuit.hs b/src/Language/PureScript/Ide/Pursuit.hs --- a/src/Language/PureScript/Ide/Pursuit.hs +++ b/src/Language/PureScript/Ide/Pursuit.hs @@ -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 +-- Stability : experimental +-- +-- | +-- Pursuit client for psc-ide +----------------------------------------------------------------------------- + {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -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 +-- Stability : experimental +-- +-- | +-- Resolves reexports for psc-ide +----------------------------------------------------------------------------- + {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TupleSections #-} + module Language.PureScript.Ide.Reexports where diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -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 +-- 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 diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -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 +-- 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) + } diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -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 +-- 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) = diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Ide/Util.hs @@ -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 +-- 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 diff --git a/src/Language/PureScript/Ide/Watcher.hs b/src/Language/PureScript/Ide/Watcher.hs --- a/src/Language/PureScript/Ide/Watcher.hs +++ b/src/Language/PureScript/Ide/Watcher.hs @@ -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 +-- Stability : experimental +-- +-- | +-- File watcher for externs files +----------------------------------------------------------------------------- + {-# LANGUAGE RecordWildCards #-} + module Language.PureScript.Ide.Watcher where import Prelude () diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -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 diff --git a/src/Language/PureScript/Parser/JS.hs b/src/Language/PureScript/Parser/JS.hs --- a/src/Language/PureScript/Parser/JS.hs +++ b/src/Language/PureScript/Parser/JS.hs @@ -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 diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -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 diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -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 diff --git a/stack-lts-5.yaml b/stack-lts-5.yaml --- a/stack-lts-5.yaml +++ b/stack-lts-5.yaml @@ -3,4 +3,5 @@ - '.' extra-deps: - bower-json-0.8.0 +- language-javascript-0.6.0.4 flags: {} diff --git a/stack-nightly.yaml b/stack-nightly.yaml --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -1,5 +1,6 @@ flags: {} packages: - '.' -extra-deps: [] +extra-deps: +- language-javascript-0.6.0.4 resolver: nightly-2016-03-17 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -3,4 +3,5 @@ - '.' extra-deps: - bower-json-0.8.0 +- language-javascript-0.6.0.4 flags: {} diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Language/PureScript/Ide/FilterSpec.hs @@ -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] diff --git a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs @@ -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) diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -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)" + ] diff --git a/tests/Language/PureScript/Ide/Integration.hs b/tests/Language/PureScript/Ide/Integration.hs new file mode 100644 --- /dev/null +++ b/tests/Language/PureScript/Ide/Integration.hs @@ -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 +-- 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') diff --git a/tests/Language/PureScript/Ide/MatcherSpec.hs b/tests/Language/PureScript/Ide/MatcherSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Language/PureScript/Ide/MatcherSpec.hs @@ -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")] diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs @@ -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"] diff --git a/tests/Language/PureScript/IdeSpec.hs b/tests/Language/PureScript/IdeSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Language/PureScript/IdeSpec.hs @@ -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"] diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -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 diff --git a/tests/support/pscide/src/ImportsSpec.purs b/tests/support/pscide/src/ImportsSpec.purs new file mode 100644 --- /dev/null +++ b/tests/support/pscide/src/ImportsSpec.purs @@ -0,0 +1,5 @@ +module ImportsSpec where + +import Main (id) + +myId = id diff --git a/tests/support/pscide/src/ImportsSpec1.purs b/tests/support/pscide/src/ImportsSpec1.purs new file mode 100644 --- /dev/null +++ b/tests/support/pscide/src/ImportsSpec1.purs @@ -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 diff --git a/tests/support/pscide/src/Main.purs b/tests/support/pscide/src/Main.purs new file mode 100644 --- /dev/null +++ b/tests/support/pscide/src/Main.purs @@ -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