summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2017-04-17 19:08:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-04-17 19:08:00 (GMT)
commitdfc751175a388290a125b6eb4dcde53a2795e7ab (patch)
tree6c68c15ba138fea5bd79e6bf02fde9aa8224d9cf
parent324579397d5a1995960306c5bda4f80b0a6269e3 (diff)
version 0.11.40.11.4
-rw-r--r--CONTRIBUTING.md2
-rw-r--r--CONTRIBUTORS.md3
-rw-r--r--app/Command/Ide.hs6
-rw-r--r--app/Command/REPL.hs2
-rw-r--r--app/Main.hs9
-rw-r--r--examples/docs/src/TypeLevelString.purs7
-rw-r--r--examples/warning/CustomWarning2.purs11
-rw-r--r--examples/warning/CustomWarning3.purs13
-rw-r--r--purescript.cabal13
-rw-r--r--src/Language/PureScript/AST/Operators.hs11
-rw-r--r--src/Language/PureScript/AST/SourcePos.hs11
-rw-r--r--src/Language/PureScript/CoreImp/Optimizer/TCO.hs25
-rw-r--r--src/Language/PureScript/Docs/RenderedCode/RenderType.hs3
-rw-r--r--src/Language/PureScript/Docs/Types.hs60
-rw-r--r--src/Language/PureScript/Environment.hs32
-rw-r--r--src/Language/PureScript/Errors.hs37
-rw-r--r--src/Language/PureScript/Ide/Imports.hs2
-rw-r--r--src/Language/PureScript/Ide/Types.hs2
-rw-r--r--src/Language/PureScript/Ide/Util.hs23
-rw-r--r--src/Language/PureScript/Ide/Watcher.hs39
-rw-r--r--src/Language/PureScript/Kinds.hs8
-rw-r--r--src/Language/PureScript/Label.hs8
-rw-r--r--src/Language/PureScript/Names.hs27
-rw-r--r--src/Language/PureScript/PSString.hs8
-rw-r--r--src/Language/PureScript/TypeChecker/Entailment.hs6
-rw-r--r--src/Language/PureScript/TypeClassDictionaries.hs7
-rw-r--r--src/Language/PureScript/Types.hs19
-rw-r--r--tests/TestDocs.hs4
28 files changed, 288 insertions, 110 deletions
diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md
index f935b7a..c76781e 100644
--- a/CONTRIBUTING.md
+++ b/CONTRIBUTING.md
@@ -4,7 +4,7 @@ Pull requests are encouraged.
## Finding Issues to Work On
-If you would like to contribute, please consider the issues in the current milestone first. If you are a new contributor, you may want to have a go at the ["easy" issues](https://github.com/purescript/purescript/labels/easy) to get started.
+If you would like to contribute, please consider the issues in the current milestone first. If you are a new contributor, you may want to have a go at the ["new contributor" issues](https://github.com/purescript/purescript/labels/new%20contributor) to get started.
## Pull Requests
diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md
index 77f2af8..b81f07f 100644
--- a/CONTRIBUTORS.md
+++ b/CONTRIBUTORS.md
@@ -31,6 +31,7 @@ If you would prefer to use different terms, please use the section below instead
| [@bsermons](https://github.com/bsermons) | Brian Sermons | [MIT license](http://opensource.org/licenses/MIT) |
| [@cdepillabout](https://github.com/cdepillabout) | Dennis Gosnell | [MIT license](http://opensource.org/licenses/MIT) |
| [@chrisdone](https://github.com/chrisdone) | Chris Done | MIT license |
+| [@cmdv](https://github.com/cmdv) | Vincent Orr | MIT license |
| [@codedmart](https://github.com/codedmart) | Brandon Martin | [MIT license](http://opensource.org/licenses/MIT) |
| [@davidchambers](https://github.com/davidchambers) | David Chambers | [MIT license](http://opensource.org/licenses/MIT) |
| [@DavidLindbom](https://github.com/DavidLindbom) | David Lindbom | [MIT license](http://opensource.org/licenses/MIT) |
@@ -87,12 +88,14 @@ If you would prefer to use different terms, please use the section below instead
| [@sebastiaanvisser](https://github.com/sebastiaanvisser) | Sebastiaan Visser | MIT license |
| [@senju](https://github.com/senju) | senju | [MIT license](http://opensource.org/licenses/MIT) |
| [@seungha-kim](https://github.com/seungha-kim) | Seungha Kim | [MIT license](http://opensource.org/licenses/MIT) |
+| [@simonyangme](https://github.com/simonyangme) | Simon Yang | [MIT license](http://opensource.org/licenses/MIT) |
| [@sharkdp](https://github.com/sharkdp) | David Peter | [MIT license](http://opensource.org/licenses/MIT) |
| [@soupi](https://github.com/soupi) | Gil Mizrahi | [MIT license](http://opensource.org/licenses/MIT) |
| [@sztupi](https://github.com/sztupi) | Attila Sztupak | [MIT license](http://opensource.org/licenses/MIT) |
| [@taktoa](https://github.com/taktoa) | Remy Goldschmidt | [MIT license](http://opensource.org/licenses/MIT) |
| [@taku0](https://github.com/taku0) | taku0 | [MIT license](http://opensource.org/licenses/MIT) |
| [@tfausak](https://github.com/tfausak) | Taylor Fausak | [MIT license](http://opensource.org/licenses/MIT) |
+| [@thoradam](https://github.com/thoradam) | Thor Adam | [MIT license](http://opensource.org/licenses/MIT) |
| [@tmcgilchrist](https://github.com/tmcgilchrist) | Tim McGilchrist | [MIT license](http://opensource.org/licenses/MIT) |
| [@trofi](https://github.com/trofi) | Sergei Trofimovich | [MIT license](http://opensource.org/licenses/MIT) |
| [@utkarshkukreti](https://github.com/utkarshkukreti) | Utkarsh Kukreti | [MIT license](http://opensource.org/licenses/MIT) |
diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs
index b7d45cc..59780de 100644
--- a/app/Command/Ide.hs
+++ b/app/Command/Ide.hs
@@ -80,10 +80,10 @@ command = Opts.helper <*> subcommands where
subcommands :: Opts.Parser (IO ())
subcommands = (Opts.subparser . fold)
[ Opts.command "server"
- (Opts.info (fmap server serverOptions)
+ (Opts.info (fmap server serverOptions <**> Opts.helper)
(Opts.progDesc "Start a server process"))
, Opts.command "client"
- (Opts.info (fmap client clientOptions)
+ (Opts.info (fmap client clientOptions <**> Opts.helper)
(Opts.progDesc "Connect to a running server"))
]
@@ -119,7 +119,7 @@ command = Opts.helper <*> subcommands where
putText "psc-ide needs you to compile your project (for example by running pulp build)"
unless noWatch $
- void (forkFinally (watcher polling ideState fullOutputPath) print)
+ void (forkFinally (watcher polling logLevel ideState fullOutputPath) print)
let conf = Configuration {confLogLevel = logLevel, confOutputPath = outputPath, confGlobs = globs}
env = IdeEnvironment {ideStateVar = ideState, ideConfiguration = conf}
startServer port env
diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs
index 24132b7..bb2e493 100644
--- a/app/Command/REPL.hs
+++ b/app/Command/REPL.hs
@@ -62,7 +62,7 @@ data PSCiOptions = PSCiOptions
inputFile :: Opts.Parser FilePath
inputFile = Opts.strArgument $
- Opts.metavar "FILE"
+ Opts.metavar "FILES"
<> Opts.help "Optional .purs files to load on start"
nodePathOption :: Opts.Parser (Maybe FilePath)
diff --git a/app/Main.hs b/app/Main.hs
index 6e4b60d..dcc4a5e 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -17,6 +17,7 @@ import qualified Command.REPL as REPL
import Data.Foldable (fold)
import Data.Monoid ((<>))
import qualified Options.Applicative as Opts
+import System.Environment (getArgs)
import qualified System.IO as IO
import Version (versionString)
@@ -25,7 +26,7 @@ main :: IO ()
main = do
IO.hSetEncoding IO.stdout IO.utf8
IO.hSetEncoding IO.stderr IO.utf8
- cmd <- Opts.execParser opts
+ cmd <- Opts.handleParseResult . execParserPure opts =<< getArgs
cmd
where
opts = Opts.info (versionInfo <*> Opts.helper <*> commands) infoModList
@@ -33,6 +34,12 @@ main = do
headerInfo = Opts.progDesc "The PureScript compiler and tools"
footerInfo = Opts.footer $ "purs " ++ versionString
+ -- | Displays full command help when invoked with no arguments.
+ execParserPure :: Opts.ParserInfo a -> [String] -> Opts.ParserResult a
+ execParserPure pinfo [] = Opts.Failure $
+ Opts.parserFailure Opts.defaultPrefs pinfo Opts.ShowHelpText mempty
+ execParserPure pinfo args = Opts.execParserPure Opts.defaultPrefs pinfo args
+
versionInfo :: Opts.Parser (a -> a)
versionInfo = Opts.abortOption (Opts.InfoMsg versionString) $
Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden
diff --git a/examples/docs/src/TypeLevelString.purs b/examples/docs/src/TypeLevelString.purs
new file mode 100644
index 0000000..34d4f03
--- /dev/null
+++ b/examples/docs/src/TypeLevelString.purs
@@ -0,0 +1,7 @@
+module TypeLevelString where
+
+data Foo
+
+class Bar a
+
+instance fooBar :: Fail "oops" => Bar Foo
diff --git a/examples/warning/CustomWarning2.purs b/examples/warning/CustomWarning2.purs
new file mode 100644
index 0000000..72afec3
--- /dev/null
+++ b/examples/warning/CustomWarning2.purs
@@ -0,0 +1,11 @@
+-- @shouldWarnWith UserDefinedWarning
+module Main where
+
+foo :: Warn "foo" => Int -> Int
+foo x = x
+
+bar :: Warn "foo" => Int
+bar = foo 42
+
+baz :: Int
+baz = bar
diff --git a/examples/warning/CustomWarning3.purs b/examples/warning/CustomWarning3.purs
new file mode 100644
index 0000000..e06f7f1
--- /dev/null
+++ b/examples/warning/CustomWarning3.purs
@@ -0,0 +1,13 @@
+-- @shouldWarnWith UserDefinedWarning
+-- @shouldWarnWith UserDefinedWarning
+module Main where
+
+foo :: Warn "foo" => Int -> Int
+foo x = x
+
+-- Defer the "foo" warning and warn with "bar" as well
+bar :: Warn "foo" => Warn "bar" => Int
+bar = foo 42
+
+baz :: Int
+baz = bar
diff --git a/purescript.cabal b/purescript.cabal
index 4932d25..b11f327 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,9 +1,9 @@
--- This file has been generated from package.yaml by hpack version 0.15.0.
+-- This file has been generated from package.yaml by hpack version 0.17.0.
--
-- see: https://github.com/sol/hpack
name: purescript
-version: 0.11.3
+version: 0.11.4
cabal-version: >= 1.10
build-type: Simple
license: BSD3
@@ -59,6 +59,7 @@ extra-source-files:
examples/docs/src/TypeClassWithFunDeps.purs
examples/docs/src/TypeClassWithoutMembers.purs
examples/docs/src/TypeClassWithoutMembersIntermediate.purs
+ examples/docs/src/TypeLevelString.purs
examples/docs/src/TypeOpAliases.purs
examples/docs/src/UTF8.purs
examples/docs/src/Virtual.purs
@@ -585,6 +586,8 @@ extra-source-files:
examples/warning/2411.purs
examples/warning/2542.purs
examples/warning/CustomWarning.purs
+ examples/warning/CustomWarning2.purs
+ examples/warning/CustomWarning3.purs
examples/warning/DuplicateExportRef.purs
examples/warning/DuplicateImport.purs
examples/warning/DuplicateImportRef.purs
@@ -645,7 +648,7 @@ flag release
library
build-depends:
- aeson >=0.8 && <1.1
+ aeson >=1.0 && <1.1
, aeson-better-errors >=0.8
, ansi-terminal >=0.6.2 && <0.7
, base >=4.8 && <5
@@ -853,7 +856,7 @@ library
executable purs
build-depends:
- aeson >=0.8 && <1.1
+ aeson >=1.0 && <1.1
, aeson-better-errors >=0.8
, ansi-terminal >=0.6.2 && <0.7
, base >=4.8 && <5
@@ -941,7 +944,7 @@ executable purs
test-suite tests
build-depends:
- aeson >=0.8 && <1.1
+ aeson >=1.0 && <1.1
, aeson-better-errors >=0.8
, ansi-terminal >=0.6.2 && <0.7
, base >=4.8 && <5
diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs
index c562e7d..ffe5377 100644
--- a/src/Language/PureScript/AST/Operators.hs
+++ b/src/Language/PureScript/AST/Operators.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveGeneric #-}
-- |
-- Operators fixity and associativity
--
@@ -5,6 +6,8 @@ module Language.PureScript.AST.Operators where
import Prelude.Compat
+import GHC.Generics (Generic)
+import Control.DeepSeq (NFData)
import Data.Aeson ((.=))
import qualified Data.Aeson as A
@@ -19,7 +22,9 @@ type Precedence = Integer
-- Associativity for infix operators
--
data Associativity = Infixl | Infixr | Infix
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData Associativity
showAssoc :: Associativity -> String
showAssoc Infixl = "infixl"
@@ -42,7 +47,9 @@ instance A.FromJSON Associativity where
-- Fixity data for infix operators
--
data Fixity = Fixity Associativity Precedence
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData Fixity
instance A.ToJSON Fixity where
toJSON (Fixity associativity precedence) =
diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs
index 5dfb98b..4c6d571 100644
--- a/src/Language/PureScript/AST/SourcePos.hs
+++ b/src/Language/PureScript/AST/SourcePos.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveGeneric #-}
-- |
-- Source position information
--
@@ -5,6 +6,8 @@ module Language.PureScript.AST.SourcePos where
import Prelude.Compat
+import GHC.Generics (Generic)
+import Control.DeepSeq (NFData)
import Data.Aeson ((.=), (.:))
import qualified Data.Aeson as A
import Data.Monoid
@@ -23,7 +26,9 @@ data SourcePos = SourcePos
-- Column number
--
, sourcePosColumn :: Int
- } deriving (Show, Eq, Ord)
+ } deriving (Show, Eq, Ord, Generic)
+
+instance NFData SourcePos
displaySourcePos :: SourcePos -> Text
displaySourcePos sp =
@@ -51,7 +56,9 @@ data SourceSpan = SourceSpan
-- End of the span
--
, spanEnd :: SourcePos
- } deriving (Show, Eq, Ord)
+ } deriving (Show, Eq, Ord, Generic)
+
+instance NFData SourceSpan
displayStartEndPos :: SourceSpan -> Text
displayStartEndPos sp =
diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
index f27a843..ab7a69d 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
@@ -7,6 +7,7 @@ import Data.Text (Text)
import Data.Monoid ((<>))
import Language.PureScript.CoreImp.AST
import Language.PureScript.AST.SourcePos (SourceSpan)
+import Safe (headDef, tailSafe)
-- | Eliminate tail calls
tco :: AST -> AST
@@ -29,10 +30,11 @@ tco = everywhere convert where
convert :: AST -> AST
convert (VariableIntroduction ss name (Just fn@Function {}))
| isTailRecursive name body'
- = VariableIntroduction ss name (Just (replace (toLoop name allArgs body')))
+ = VariableIntroduction ss name (Just (replace (toLoop name outerArgs innerArgs body')))
where
+ innerArgs = headDef [] argss
+ outerArgs = concat . reverse $ tailSafe argss
(argss, body', replace) = collectAllFunctionArgs [] id fn
- allArgs = concat $ reverse argss
convert js = js
collectAllFunctionArgs :: [[Text]] -> (AST -> AST) -> AST -> ([[Text]], AST, AST -> AST)
@@ -79,21 +81,16 @@ tco = everywhere convert where
allInTailPosition _
= False
- toLoop :: Text -> [Text] -> AST -> AST
- toLoop ident allArgs js =
+ toLoop :: Text -> [Text] -> [Text] -> AST -> AST
+ toLoop ident outerArgs innerArgs js =
Block rootSS $
- map (\arg -> VariableIntroduction rootSS arg (Just (Var rootSS (copyVar arg)))) allArgs ++
+ map (\arg -> VariableIntroduction rootSS (tcoVar arg) (Just (Var rootSS (copyVar arg)))) outerArgs ++
[ VariableIntroduction rootSS tcoDone (Just (BooleanLiteral rootSS False))
, VariableIntroduction rootSS tcoResult Nothing
- ] ++
- map (\arg ->
- VariableIntroduction rootSS (tcoVar arg) Nothing) allArgs ++
- [ Function rootSS (Just tcoLoop) allArgs (Block rootSS [loopify js])
+ , Function rootSS (Just tcoLoop) (outerArgs ++ innerArgs) (Block rootSS [loopify js])
, While rootSS (Unary rootSS Not (Var rootSS tcoDone))
(Block rootSS
- (Assignment rootSS (Var rootSS tcoResult) (App rootSS (Var rootSS tcoLoop) (map (Var rootSS) allArgs))
- : map (\arg ->
- Assignment rootSS (Var rootSS arg) (Var rootSS (tcoVar arg))) allArgs))
+ [(Assignment rootSS (Var rootSS tcoResult) (App rootSS (Var rootSS tcoLoop) ((map (Var rootSS . tcoVar) outerArgs) ++ (map (Var rootSS . copyVar) innerArgs))))])
, Return rootSS (Var rootSS tcoResult)
]
where
@@ -107,7 +104,9 @@ tco = everywhere convert where
in
Block ss $
zipWith (\val arg ->
- Assignment ss (Var ss (tcoVar arg)) val) allArgumentValues allArgs
+ Assignment ss (Var ss (tcoVar arg)) val) allArgumentValues outerArgs
+ ++ zipWith (\val arg ->
+ Assignment ss (Var ss (copyVar arg)) val) (drop (length outerArgs) allArgumentValues) innerArgs
++ [ ReturnNoResult ss ]
| otherwise = Block ss [ markDone ss, Return ss ret ]
loopify (ReturnNoResult ss) = Block ss [ markDone ss, ReturnNoResult ss ]
diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs
index e8dae46..15f51dc 100644
--- a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs
+++ b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs
@@ -26,6 +26,7 @@ import Language.PureScript.Names
import Language.PureScript.Pretty.Types
import Language.PureScript.Types
import Language.PureScript.Label (Label)
+import Language.PureScript.PSString (prettyPrintString)
import Language.PureScript.Docs.RenderedCode.Types
import Language.PureScript.Docs.Utils.MonoidExtras
@@ -54,6 +55,8 @@ typeLiterals = mkPattern match
Just $ renderTypeAtom l <> sp <> renderTypeAtom op <> sp <> renderTypeAtom r
match (TypeOp n) =
Just (typeOp n)
+ match (TypeLevelString str) =
+ Just (syntax (prettyPrintString str))
match _ =
Nothing
diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs
index 8190415..f97a25d 100644
--- a/src/Language/PureScript/Docs/Types.hs
+++ b/src/Language/PureScript/Docs/Types.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE DeriveGeneric #-}
+
module Language.PureScript.Docs.Types
( module Language.PureScript.Docs.Types
, module ReExports
@@ -7,6 +9,8 @@ module Language.PureScript.Docs.Types
import Protolude hiding (to, from)
import Prelude (String, unlines, lookup)
+import GHC.Generics (Generic)
+import Control.DeepSeq (NFData)
import Control.Arrow ((***))
import Data.Aeson ((.=))
@@ -55,10 +59,14 @@ data Package a = Package
-- ^ The version of the PureScript compiler which was used to generate
-- this data. We store this in order to reject packages which are too old.
}
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData a => NFData (Package a)
data NotYetKnown = NotYetKnown
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData NotYetKnown
type UploadedPackage = Package NotYetKnown
type VerifiedPackage = Package GithubUser
@@ -111,7 +119,9 @@ data Module = Module
-- Re-exported values from other modules
, modReExports :: [(InPackage P.ModuleName, [Declaration])]
}
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData Module
data Declaration = Declaration
{ declTitle :: Text
@@ -120,7 +130,9 @@ data Declaration = Declaration
, declChildren :: [ChildDeclaration]
, declInfo :: DeclarationInfo
}
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData Declaration
-- |
-- A value of this type contains information that is specific to a particular
@@ -170,7 +182,9 @@ data DeclarationInfo
-- A kind declaration
--
| ExternKindDeclaration
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData DeclarationInfo
convertFundepsToStrings :: [(Text, Maybe P.Kind)] -> [P.FunctionalDependency] -> [([Text], [Text])]
convertFundepsToStrings args fundeps =
@@ -265,7 +279,9 @@ data ChildDeclaration = ChildDeclaration
, cdeclSourceSpan :: Maybe P.SourceSpan
, cdeclInfo :: ChildDeclarationInfo
}
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData ChildDeclaration
data ChildDeclarationInfo
-- |
@@ -284,7 +300,9 @@ data ChildDeclarationInfo
-- example, `pure` from `Applicative` would be `forall a. a -> f a`.
--
| ChildTypeClassMember P.Type
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData ChildDeclarationInfo
childDeclInfoToString :: ChildDeclarationInfo -> Text
childDeclInfoToString (ChildInstance _ _) = "instance"
@@ -319,11 +337,15 @@ isDataConstructor ChildDeclaration{..} =
newtype GithubUser
= GithubUser { runGithubUser :: Text }
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData GithubUser
newtype GithubRepo
= GithubRepo { runGithubRepo :: Text }
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData GithubRepo
data PackageError
= CompilerTooOld Version Version
@@ -337,12 +359,16 @@ data PackageError
| InvalidKind Text
| InvalidDataDeclType Text
| InvalidTime
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData PackageError
data InPackage a
= Local a
| FromDep PackageName a
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData a => NFData (InPackage a)
instance Functor InPackage where
fmap f (Local x) = Local (f x)
@@ -370,14 +396,18 @@ data LinksContext = LinksContext
, ctxVersion :: Version
, ctxVersionTag :: Text
}
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData LinksContext
data DocLink = DocLink
{ linkLocation :: LinkLocation
, linkTitle :: Text
, linkNamespace :: Namespace
}
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData DocLink
data LinkLocation
-- | A link to a declaration in the same module.
@@ -397,7 +427,9 @@ data LinkLocation
-- module. In this case we only need to store the module that the builtin
-- comes from (at the time of writing, this will only ever be "Prim").
| BuiltinModule P.ModuleName
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData LinkLocation
-- | Given a links context, the current module name, the namespace of a thing
-- to link to, its title, and its containing module, attempt to create a
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index b0f0c7b..7d11443 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -1,8 +1,12 @@
+{-# LANGUAGE DeriveGeneric #-}
+
module Language.PureScript.Environment where
import Prelude.Compat
import Protolude (ordNub)
+import GHC.Generics (Generic)
+import Control.DeepSeq (NFData)
import Data.Aeson ((.=), (.:))
import qualified Data.Aeson as A
import qualified Data.Map as M
@@ -38,7 +42,9 @@ data Environment = Environment
-- ^ Type classes
, kinds :: S.Set (Qualified (ProperName 'KindName))
-- ^ Kinds in scope
- } deriving Show
+ } deriving (Show, Generic)
+
+instance NFData Environment
-- | Information about a type class
data TypeClassData = TypeClassData
@@ -59,7 +65,9 @@ data TypeClassData = TypeClassData
-- typeClassArguments and typeClassDependencies.
, typeClassCoveringSets :: S.Set (S.Set Int)
-- ^ A sets of arguments that can be used to infer all other arguments.
- } deriving Show
+ } deriving (Show, Generic)
+
+instance NFData TypeClassData
-- | A functional dependency indicates a relationship between two sets of
-- type arguments in a class declaration.
@@ -68,7 +76,9 @@ data FunctionalDependency = FunctionalDependency
-- ^ the type arguments which determine the determined type arguments
, fdDetermined :: [Int]
-- ^ the determined type arguments
- } deriving Show
+ } deriving (Show, Generic)
+
+instance NFData FunctionalDependency
instance A.FromJSON FunctionalDependency where
parseJSON = A.withObject "FunctionalDependency" $ \o ->
@@ -164,7 +174,9 @@ data NameVisibility
-- ^ The name is defined in the current binding group, but is not visible
| Defined
-- ^ The name is defined in the another binding group, or has been made visible by a function binder
- deriving (Show, Eq)
+ deriving (Show, Eq, Generic)
+
+instance NFData NameVisibility
-- | A flag for whether a name is for an private or public value - only public values will be
-- included in a generated externs file.
@@ -176,7 +188,9 @@ data NameKind
-- ^ A public value for a module member or foreing import declaration
| External
-- ^ A name for member introduced by foreign import
- deriving (Show, Eq)
+ deriving (Show, Eq, Generic)
+
+instance NFData NameKind
-- | The kinds of a type
data TypeKind
@@ -190,7 +204,9 @@ data TypeKind
-- ^ A local type variable
| ScopedTypeVar
-- ^ A scoped type variable
- deriving (Show, Eq)
+ deriving (Show, Eq, Generic)
+
+instance NFData TypeKind
instance A.ToJSON TypeKind where
toJSON (DataType args ctors) =
@@ -221,7 +237,9 @@ data DataDeclType
-- ^ A standard data constructor
| Newtype
-- ^ A newtype constructor
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData DataDeclType
showDataDeclType :: DataDeclType -> Text
showDataDeclType Data = "data"
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index d0ca60d..1314b7a 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -18,10 +18,8 @@ import Data.Char (isSpace)
import Data.Either (partitionEithers)
import Data.Foldable (fold)
import Data.Functor.Identity (Identity(..))
-import Data.List (transpose, nubBy, sortBy, partition, dropWhileEnd)
+import Data.List (transpose, nubBy, sort, partition, dropWhileEnd)
import Data.Maybe (maybeToList, fromMaybe, mapMaybe)
-import Data.Ord (comparing)
-import Data.String (fromString)
import qualified Data.Map as M
import qualified Data.Text as T
import Data.Text (Text)
@@ -34,7 +32,7 @@ import Language.PureScript.Label (Label(..))
import Language.PureScript.Names
import Language.PureScript.Pretty
import Language.PureScript.Pretty.Common (endWith)
-import Language.PureScript.PSString (PSString, decodeStringWithReplacement)
+import Language.PureScript.PSString (decodeStringWithReplacement)
import Language.PureScript.Traversals
import Language.PureScript.Types
import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers
@@ -567,15 +565,11 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
-- Put the common labels last
sortRows' :: ([(Label, Type)], Type) -> ([(Label, Type)], Type) -> (Type, Type)
sortRows' (s1, r1) (s2, r2) =
- let common :: [(Label, (Type, Type))]
- common = sortBy (comparing fst) [ (name, (t1, t2)) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
-
- sd1, sd2 :: [(Label, Type)]
- sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
- sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
- in ( rowFromList (sortBy (comparing fst) sd1 ++ map (fst &&& fst . snd) common, r1)
- , rowFromList (sortBy (comparing fst) sd2 ++ map (fst &&& snd . snd) common, r2)
- )
+ let (common1, unique1) = partition (flip elem s2) s1
+ (common2, unique2) = partition (flip elem s1) s2
+ in ( rowFromList (sort unique1 ++ sort common1, r1)
+ , rowFromList (sort unique2 ++ sort common2, r2)
+ )
in paras [ line "Could not match type"
, markCodeBox $ indent $ typeAsBox sorted1
, line "with type"
@@ -1313,15 +1307,14 @@ renderBox = unlines
whiteSpace = all isSpace
toTypelevelString :: Type -> Maybe Box.Box
-toTypelevelString t = (Box.text . decodeStringWithReplacement) <$> toTypelevelString' t
- where
- toTypelevelString' :: Type -> Maybe PSString
- toTypelevelString' (TypeLevelString s) = Just s
- toTypelevelString' (TypeApp (TypeConstructor f) x)
- | f == primName "TypeString" = Just $ fromString $ prettyPrintType x
- toTypelevelString' (TypeApp (TypeApp (TypeConstructor f) x) ret)
- | f == primName "TypeConcat" = toTypelevelString' x <> toTypelevelString' ret
- toTypelevelString' _ = Nothing
+toTypelevelString (TypeLevelString s) =
+ Just . Box.text $ decodeStringWithReplacement s
+toTypelevelString (TypeApp (TypeConstructor f) x)
+ | f == primName "TypeString" = Just (typeAsBox x)
+toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret)
+ | f == primName "TypeConcat" =
+ (Box.<>) <$> toTypelevelString x <*> toTypelevelString ret
+toTypelevelString _ = Nothing
-- | Rethrow an error with a more detailed error message in the case of failure
rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs
index ba18315..fd14946 100644
--- a/src/Language/PureScript/Ide/Imports.hs
+++ b/src/Language/PureScript/Ide/Imports.hs
@@ -85,7 +85,7 @@ parseImportsFromFile file = do
parseImportsFromFile' :: (MonadIO m, MonadError IdeError m) =>
FilePath -> m (P.ModuleName, [Text], [Import], [Text])
parseImportsFromFile' fp = do
- file <- ideReadFile fp
+ file <- ideReadTextFile fp
case sliceImportSection (T.lines file) of
Right res -> pure res
Left err -> throwError (GeneralError err)
diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs
index 5abd68b..332da88 100644
--- a/src/Language/PureScript/Ide/Types.hs
+++ b/src/Language/PureScript/Ide/Types.hs
@@ -229,7 +229,7 @@ instance ToJSON Success where
toJSON (PursuitResult resp) = encodeSuccess resp
toJSON (ImportList (moduleName, imports)) = object [ "resultType" .= ("success" :: Text)
, "result" .= object [ "imports" .= map encodeImport imports
- , "moduleName" .= moduleName]]
+ , "moduleName" .= P.runModuleName moduleName]]
toJSON (ModuleList modules) = encodeSuccess modules
toJSON (RebuildSuccess warnings) = encodeSuccess (P.toJSONErrors False P.Warning warnings)
diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs
index c96b745..0d8bee9 100644
--- a/src/Language/PureScript/Ide/Util.hs
+++ b/src/Language/PureScript/Ide/Util.hs
@@ -28,6 +28,7 @@ module Language.PureScript.Ide.Util
, identT
, opNameT
, ideReadFile
+ , ideReadTextFile
, module Language.PureScript.Ide.Logging
) where
@@ -37,6 +38,7 @@ import Protolude hiding (decodeUtf8,
import Control.Lens hiding ((&), op)
import Data.Aeson
import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)
import qualified Language.PureScript as P
@@ -129,10 +131,25 @@ identT = iso P.runIdent P.Ident
opNameT :: Iso' (P.OpName a) Text
opNameT = iso P.runOpName P.OpName
-ideReadFile :: (MonadIO m, MonadError IdeError m) => FilePath -> m Text
-ideReadFile fp = do
- contents :: Either IOException Text <- liftIO (try (readUTF8FileT fp))
+ideReadFile'
+ :: (MonadIO m, MonadError IdeError m)
+ => (FilePath -> IO Text)
+ -> FilePath
+ -> m Text
+ideReadFile' fileReader fp = do
+ contents :: Either IOException Text <- liftIO (try (fileReader fp))
either
(\_ -> throwError (GeneralError ("Couldn't find file at: " <> T.pack fp)))
pure
contents
+
+ideReadFile :: (MonadIO m, MonadError IdeError m) => FilePath -> m Text
+ideReadFile = ideReadFile' readUTF8FileT
+
+-- | This function is to be used over @ideReadFile@ when the result is not just
+-- passed on to the PureScript parser, but also needs to be treated as lines of
+-- text. Because @ideReadFile@ reads the file as ByteString in @BinaryMode@
+-- rather than @TextMode@ line endings get mangled on Windows otherwise. This is
+-- irrelevant for parsing, because the Lexer strips these additional @\r@'s.
+ideReadTextFile :: (MonadIO m, MonadError IdeError m) => FilePath -> m Text
+ideReadTextFile = ideReadFile' TIO.readFile
diff --git a/src/Language/PureScript/Ide/Watcher.hs b/src/Language/PureScript/Ide/Watcher.hs
index 97b45b5..a966679 100644
--- a/src/Language/PureScript/Ide/Watcher.hs
+++ b/src/Language/PureScript/Ide/Watcher.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE PackageImports #-}
-----------------------------------------------------------------------------
--
-- Module : Language.PureScript.Ide.Watcher
@@ -16,38 +17,40 @@ module Language.PureScript.Ide.Watcher
( watcher
) where
-import Protolude
+import Protolude
-import Control.Concurrent.STM
-import Language.PureScript.Ide.Externs
-import Language.PureScript.Ide.State
-import Language.PureScript.Ide.Types
-import Language.PureScript.Ide.Util
-import System.FilePath
-import System.FSNotify
+import Control.Concurrent.STM
+import "monad-logger" Control.Monad.Logger
+import Language.PureScript.Ide.Externs
+import Language.PureScript.Ide.State
+import Language.PureScript.Ide.Types
+import Language.PureScript.Ide.Util
+import System.FSNotify
+import System.FilePath
-- | Reloads an ExternsFile from Disc. If the Event indicates the ExternsFile
-- was deleted we don't do anything.
-reloadFile :: TVar IdeState -> Event -> IO ()
-reloadFile _ Removed{} = pure ()
-reloadFile ref ev = do
+reloadFile :: IdeLogLevel -> TVar IdeState -> Event -> IO ()
+reloadFile _ _ Removed{} = pure ()
+reloadFile logLevel ref ev = runLogger logLevel $ do
let fp = eventPath ev
- ef' <- runLogger LogDefault (runExceptT (readExternFile fp))
+ ef' <- runExceptT (readExternFile fp)
case ef' of
- Left _ -> pure ()
+ Left err ->
+ logErrorN ("Failed to reload file at: " <> toS fp <> " with error: " <> show err)
Right ef -> do
- void $ atomically (insertExternsSTM ref ef *> populateStage3STM ref)
- putStrLn ("Reloaded File at: " ++ fp)
+ lift $ void $ atomically (insertExternsSTM ref ef *> populateStage3STM ref)
+ logDebugN ("Reloaded File at: " <> toS fp)
-- | Installs filewatchers for the given directory and reloads ExternsFiles when
-- they change on disc
-watcher :: Bool -> TVar IdeState -> FilePath -> IO ()
-watcher polling stateVar fp =
+watcher :: Bool -> IdeLogLevel -> TVar IdeState -> FilePath -> IO ()
+watcher polling logLevel stateVar fp =
withManagerConf
(defaultConfig { confDebounce = NoDebounce
, confUsePolling = polling
}) $ \mgr -> do
_ <- watchTree mgr fp
(\ev -> takeFileName (eventPath ev) == "externs.json")
- (reloadFile stateVar)
+ (reloadFile logLevel stateVar)
forever (threadDelay 100000)
diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs
index 696dd36..8de3b29 100644
--- a/src/Language/PureScript/Kinds.hs
+++ b/src/Language/PureScript/Kinds.hs
@@ -1,7 +1,11 @@
+{-# LANGUAGE DeriveGeneric #-}
+
module Language.PureScript.Kinds where
import Prelude.Compat
+import GHC.Generics (Generic)
+import Control.DeepSeq (NFData)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Aeson.BetterErrors (Parse, key, asText, asIntegral, nth, fromAesonParser, toAesonParser, throwCustomError)
@@ -21,7 +25,9 @@ data Kind
| FunKind Kind Kind
-- | A named kind
| NamedKind (Qualified (ProperName 'KindName))
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData Kind
-- This is equivalent to the derived Aeson ToJSON instance, except that we
-- write it out manually so that we can define a parser which is
diff --git a/src/Language/PureScript/Label.hs b/src/Language/PureScript/Label.hs
index 3c8123d..b00db4f 100644
--- a/src/Language/PureScript/Label.hs
+++ b/src/Language/PureScript/Label.hs
@@ -1,7 +1,11 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveGeneric #-}
+
module Language.PureScript.Label (Label(..)) where
import Prelude.Compat hiding (lex)
+import GHC.Generics (Generic)
+import Control.DeepSeq (NFData)
import Data.Monoid ()
import Data.String (IsString(..))
import qualified Data.Aeson as A
@@ -13,4 +17,6 @@ import Language.PureScript.PSString (PSString)
-- because records are indexable by PureScript strings at runtime.
--
newtype Label = Label { runLabel :: PSString }
- deriving (Show, Eq, Ord, IsString, Monoid, A.ToJSON, A.FromJSON)
+ deriving (Show, Eq, Ord, IsString, Monoid, A.ToJSON, A.FromJSON, Generic)
+
+instance NFData Label
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index 0c50643..c804b20 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveGeneric #-}
-- |
-- Data types for names
@@ -8,7 +9,9 @@ module Language.PureScript.Names where
import Prelude.Compat
import Control.Monad.Supply.Class
+import Control.DeepSeq (NFData)
+import GHC.Generics (Generic)
import Data.Aeson
import Data.Aeson.TH
import Data.Monoid ((<>))
@@ -25,7 +28,9 @@ data Name
| TyClassName (ProperName 'ClassName)
| ModName ModuleName
| KiName (ProperName 'KindName)
- deriving (Eq, Ord, Show)
+ deriving (Eq, Ord, Show, Generic)
+
+instance NFData Name
getIdentName :: Name -> Maybe Ident
getIdentName (IdentName name) = Just name
@@ -67,7 +72,9 @@ data Ident
-- A generated name for an identifier
--
| GenIdent (Maybe Text) Integer
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData Ident
runIdent :: Ident -> Text
runIdent (Ident i) = i
@@ -87,7 +94,9 @@ freshIdent' = GenIdent Nothing <$> fresh
-- Operator alias names.
--
newtype OpName (a :: OpNameType) = OpName { runOpName :: Text }
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData (OpName a)
instance ToJSON (OpName a) where
toJSON = toJSON . runOpName
@@ -107,7 +116,9 @@ data OpNameType = ValueOpName | TypeOpName
-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
--
newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: Text }
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData (ProperName a)
instance ToJSON (ProperName a) where
toJSON = toJSON . runProperName
@@ -137,7 +148,9 @@ coerceProperName = ProperName . runProperName
-- Module names
--
newtype ModuleName = ModuleName [ProperName 'Namespace]
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData ModuleName
runModuleName :: ModuleName -> Text
runModuleName (ModuleName pns) = T.intercalate "." (runProperName <$> pns)
@@ -154,7 +167,9 @@ moduleNameFromString = ModuleName . splitProperNames
-- A qualified name, i.e. a name with an optional module name
--
data Qualified a = Qualified (Maybe ModuleName) a
- deriving (Show, Eq, Ord, Functor)
+ deriving (Show, Eq, Ord, Functor, Generic)
+
+instance NFData a => NFData (Qualified a)
showQualified :: (a -> Text) -> Qualified a -> Text
showQualified f (Qualified Nothing a) = f a
diff --git a/src/Language/PureScript/PSString.hs b/src/Language/PureScript/PSString.hs
index 0073f0f..0dcb3b4 100644
--- a/src/Language/PureScript/PSString.hs
+++ b/src/Language/PureScript/PSString.hs
@@ -1,5 +1,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric #-}
+
module Language.PureScript.PSString
( PSString
, toUTF16CodeUnits
@@ -12,6 +14,8 @@ module Language.PureScript.PSString
) where
import Prelude.Compat
+import GHC.Generics (Generic)
+import Control.DeepSeq (NFData)
import Control.Exception (try, evaluate)
import Control.Applicative ((<|>))
import Data.Char (chr)
@@ -48,7 +52,9 @@ import qualified Data.Aeson.Types as A
-- and arrays of UTF-16 code units (integers) otherwise.
--
newtype PSString = PSString { toUTF16CodeUnits :: [Word16] }
- deriving (Eq, Ord, Monoid)
+ deriving (Eq, Ord, Monoid, Generic)
+
+instance NFData PSString
instance Show PSString where
show = show . codePoints
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
index eeabfd7..e9f3d84 100644
--- a/src/Language/PureScript/TypeChecker/Entailment.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -152,8 +152,10 @@ entails SolverOptions{..} constraint context hints =
solve constraint
where
forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDict]
- forClassName _ C.Warn [msg] =
- [TypeClassDictionaryInScope (WarnInstance msg) [] C.Warn [msg] Nothing]
+ forClassName ctx cn@C.Warn [msg] =
+ -- Prefer a warning dictionary in scope if there is one available.
+ -- This allows us to defer a warning by propagating the constraint.
+ findDicts ctx cn Nothing ++ [TypeClassDictionaryInScope (WarnInstance msg) [] C.Warn [msg] Nothing]
forClassName _ C.IsSymbol [TypeLevelString sym] =
[TypeClassDictionaryInScope (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing]
forClassName _ C.CompareSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] =
diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs
index 3b3448a..70d138b 100644
--- a/src/Language/PureScript/TypeClassDictionaries.hs
+++ b/src/Language/PureScript/TypeClassDictionaries.hs
@@ -1,9 +1,12 @@
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DeriveGeneric #-}
module Language.PureScript.TypeClassDictionaries where
import Prelude.Compat
+import GHC.Generics (Generic)
+import Control.DeepSeq (NFData)
import Data.Monoid ((<>))
import Data.Text (Text, pack)
@@ -26,7 +29,9 @@ data TypeClassDictionaryInScope v
-- | Type class dependencies which must be satisfied to construct this dictionary
, tcdDependencies :: Maybe [Constraint]
}
- deriving (Show, Functor, Foldable, Traversable)
+ deriving (Show, Functor, Foldable, Traversable, Generic)
+
+instance NFData v => NFData (TypeClassDictionaryInScope v)
type NamedDict = TypeClassDictionaryInScope (Qualified Ident)
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index f68a5aa..3bc2899 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveGeneric #-}
-- |
-- Data types for types
@@ -10,6 +11,7 @@ import Prelude.Compat
import Protolude (ordNub)
import Control.Arrow (first)
+import Control.DeepSeq (NFData)
import Control.Monad ((<=<))
import qualified Data.Aeson as A
import qualified Data.Aeson.TH as A
@@ -19,6 +21,7 @@ import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
+import GHC.Generics (Generic)
import Language.PureScript.AST.SourcePos
import Language.PureScript.Kinds
@@ -30,7 +33,9 @@ import Language.PureScript.PSString (PSString)
-- An identifier for the scope of a skolem variable
--
newtype SkolemScope = SkolemScope { runSkolemScope :: Int }
- deriving (Show, Eq, Ord, A.ToJSON, A.FromJSON)
+ deriving (Show, Eq, Ord, A.ToJSON, A.FromJSON, Generic)
+
+instance NFData SkolemScope
-- |
-- The type of types
@@ -78,7 +83,9 @@ data Type
-- Note: although it seems this constructor is not used, it _is_ useful,
-- since it prevents certain traversals from matching.
| ParensInType Type
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData Type
-- | Additional data relevant to type class constraints
data ConstraintData
@@ -88,7 +95,9 @@ data ConstraintData
-- not matched, and a flag indicating whether the list was truncated or not.
-- Note: we use 'Text' here because using 'Binder' would introduce a cyclic
-- dependency in the module graph.
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData ConstraintData
-- | A typeclass constraint
data Constraint = Constraint
@@ -98,7 +107,9 @@ data Constraint = Constraint
-- ^ type arguments
, constraintData :: Maybe ConstraintData
-- ^ additional data relevant to this constraint
- } deriving (Show, Eq, Ord)
+ } deriving (Show, Eq, Ord, Generic)
+
+instance NFData Constraint
mapConstraintArgs :: ([Type] -> [Type]) -> Constraint -> Constraint
mapConstraintArgs f c = c { constraintArgs = f (constraintArgs c) }
diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs
index 34863ea..788ef88 100644
--- a/tests/TestDocs.hs
+++ b/tests/TestDocs.hs
@@ -398,6 +398,10 @@ testCases =
, ("DocComments",
[ ShouldHaveDocComment (n "DocComments") "example" " example == 0"
])
+
+ , ("TypeLevelString",
+ [ ShouldBeDocumented (n "TypeLevelString") "Foo" ["fooBar"]
+ ])
]
where