summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2016-10-02 21:45:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-10-02 21:45:00 (GMT)
commite5b503a26b0ba5a50755c25430e73c644877fdbe (patch)
treefa2683cbabe53f85c61af2806108ad5616f2cd97
parent2acef0fe7e56d4fd60d611d3cf48b5ea37537fd0 (diff)
version 0.10.10.10.1
-rw-r--r--CONTRIBUTORS.md2
-rw-r--r--LICENSE28
-rw-r--r--examples/failing/DuplicateModule.purs2
-rw-r--r--examples/failing/DuplicateModule/M1.purs1
-rw-r--r--examples/failing/NewtypeInstance5.purs8
-rw-r--r--examples/failing/NewtypeInstance6.purs8
-rw-r--r--examples/passing/DeriveNewtype.purs10
-rw-r--r--examples/passing/NewtypeInstance.purs11
-rw-r--r--examples/warning/UnusedExplicitImportTypeOp.purs9
-rw-r--r--examples/warning/UnusedExplicitImportTypeOp/Lib.purs8
-rw-r--r--examples/warning/UnusedExplicitImportValOp.purs8
-rw-r--r--purescript.cabal16
-rw-r--r--src/Language/PureScript/AST/Declarations.hs9
-rw-r--r--src/Language/PureScript/Errors.hs15
-rw-r--r--src/Language/PureScript/Linter/Imports.hs24
-rw-r--r--src/Language/PureScript/Make.hs26
-rw-r--r--src/Language/PureScript/Sugar/Names.hs15
-rwxr-xr-xsrc/Language/PureScript/Sugar/TypeClasses/Deriving.hs91
-rw-r--r--src/System/IO/UTF8.hs19
-rw-r--r--stack.yaml10
20 files changed, 194 insertions, 126 deletions
diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md
index 7025494..5f0f220 100644
--- a/CONTRIBUTORS.md
+++ b/CONTRIBUTORS.md
@@ -5,6 +5,7 @@ This file lists the contributors to the PureScript compiler project, and the ter
### Individuals
- [@5outh](https://github.com/5outh) (Benjamin Kovach) - My existing contributions and all future contributions until further notice are Copyright Benjamin Kovach, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
+- [@andreypopp](https://github.com/andreypopp) (Andrey Popp) My existing contributions and all future contributions until further notice are Copyright Andrey Popp, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
- [@andyarvanitis](https://github.com/andyarvanitis) (Andy Arvanitis) My existing contributions and all future contributions until further notice are Copyright Andy Arvanitis, 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).
- [@anthok88](https://github.com/anthoq88) - My existing contributions and all future contributions until further notice are Copyright anthoq88, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license
- [@ardumont](https://github.com/ardumont) (Antoine R. Dumont) My existing contributions and all future contributions until further notice are Copyright Antoine R. Dumont, 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).
@@ -17,6 +18,7 @@ This file lists the contributors to the PureScript compiler project, and the ter
- [@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).
- [@cdepillabout](https://github.com/cdepillabout) (Dennis Gosnell) My existing contributions and all future contributions until further notice are Copyright Dennis Gosnell, 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).
- [@charleso](https://github.com/charleso) (Charles O'Farrell) My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Charles O'Farrell, 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).
+- [@chrisdone](https://github.com/chrisdone) (Chris Done) - My existing contributions and all future contributions until further notice are Copyright Chris Done, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
- [@chrissmoak](https://github.com/chrissmoak) (Chris Smoak) My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Chris Smoak, 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).
- [@codedmart](https://github.com/codedmart) (Brandon Martin) My existing contributions and all future contributions until further notice are Copyright Brandon Martin, 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).
- [@davidchambers](https://github.com/davidchambers) (David Chambers) My existing contributions and all future contributions until further notice are Copyright David Chambers, 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).
diff --git a/LICENSE b/LICENSE
index d05ff61..d392d3d 100644
--- a/LICENSE
+++ b/LICENSE
@@ -1,24 +1,16 @@
-The MIT License (MIT)
-
-Copyright (c) 2013-15 Phil Freeman, (c) 2014-2015 Gary Burgess, and other
+Copyright (c) 2013-16 Phil Freeman, (c) 2014-2016 Gary Burgess, and other
contributors
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
-Permission is hereby granted, free of charge, to any person obtaining a copy of
-this software and associated documentation files (the "Software"), to deal in
-the Software without restriction, including without limitation the rights to
-use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
-the Software, and to permit persons to whom the Software is furnished to do so,
-subject to the following conditions:
+2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
-The above copyright notice and this permission notice shall be included in all
-copies or substantial portions of the Software.
+3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
-THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
-FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
-COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
-IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
-CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
PureScript uses the following Haskell library packages. Their license files follow.
@@ -2900,7 +2892,7 @@ pipes LICENSE file:
pipes-http LICENSE file:
- Copyright (c) 2014 Gabriel Gonzalez
+ Copyright (c) 2016 Gabriel Gonzalez
All rights reserved.
Redistribution and use in source and binary forms, with or without modification,
diff --git a/examples/failing/DuplicateModule.purs b/examples/failing/DuplicateModule.purs
new file mode 100644
index 0000000..5cd8a13
--- /dev/null
+++ b/examples/failing/DuplicateModule.purs
@@ -0,0 +1,2 @@
+-- @shouldFailWith DuplicateModule
+module M1 where
diff --git a/examples/failing/DuplicateModule/M1.purs b/examples/failing/DuplicateModule/M1.purs
new file mode 100644
index 0000000..5d99c37
--- /dev/null
+++ b/examples/failing/DuplicateModule/M1.purs
@@ -0,0 +1 @@
+module M1 where
diff --git a/examples/failing/NewtypeInstance5.purs b/examples/failing/NewtypeInstance5.purs
new file mode 100644
index 0000000..5003ee8
--- /dev/null
+++ b/examples/failing/NewtypeInstance5.purs
@@ -0,0 +1,8 @@
+-- @shouldFailWith InvalidNewtypeInstance
+module Main where
+
+import Prelude
+
+newtype X a = X a
+
+derive newtype instance functorX :: Functor X
diff --git a/examples/failing/NewtypeInstance6.purs b/examples/failing/NewtypeInstance6.purs
new file mode 100644
index 0000000..fe71366
--- /dev/null
+++ b/examples/failing/NewtypeInstance6.purs
@@ -0,0 +1,8 @@
+-- @shouldFailWith InvalidNewtypeInstance
+module Main where
+
+import Prelude
+
+newtype X a b = X (Array b)
+
+derive newtype instance functorX :: Functor X
diff --git a/examples/passing/DeriveNewtype.purs b/examples/passing/DeriveNewtype.purs
index 6b05c0d..bdcdce4 100644
--- a/examples/passing/DeriveNewtype.purs
+++ b/examples/passing/DeriveNewtype.purs
@@ -14,4 +14,14 @@ t = wrap "hello"
a :: String
a = unwrap t
+newtype First a = First a
+
+derive instance newtypeFirst :: Newtype (First b) _
+
+f :: First Int
+f = wrap 1
+
+i :: Int
+i = unwrap f
+
main = log "Done"
diff --git a/examples/passing/NewtypeInstance.purs b/examples/passing/NewtypeInstance.purs
index 416405a..8a83399 100644
--- a/examples/passing/NewtypeInstance.purs
+++ b/examples/passing/NewtypeInstance.purs
@@ -24,7 +24,18 @@ instance singletonArray :: Singleton a (Array a) where
derive newtype instance singletonY :: Singleton a (Y a)
+newtype MyArray a = MyArray (Array a)
+
+derive newtype instance showMyArray :: Show a => Show (MyArray a)
+
+derive newtype instance functorMyArray :: Functor MyArray
+
+newtype ProxyArray x a = ProxyArray (Array a)
+
+derive newtype instance functorProxyArray :: Functor (ProxyArray x)
+
main = do
logShow (X "test")
logShow (singleton "test" :: Y String)
+ logShow (map show (MyArray [1, 2, 3]))
log "Done"
diff --git a/examples/warning/UnusedExplicitImportTypeOp.purs b/examples/warning/UnusedExplicitImportTypeOp.purs
new file mode 100644
index 0000000..41caf6b
--- /dev/null
+++ b/examples/warning/UnusedExplicitImportTypeOp.purs
@@ -0,0 +1,9 @@
+-- @shouldWarnWith UnusedExplicitImport
+module Main where
+
+import Prelude (Unit, unit, pure)
+import Control.Monad.Eff (Eff)
+import Lib (type (~>), natId)
+
+main :: Eff () Unit
+main = natId (pure unit)
diff --git a/examples/warning/UnusedExplicitImportTypeOp/Lib.purs b/examples/warning/UnusedExplicitImportTypeOp/Lib.purs
new file mode 100644
index 0000000..7a2d523
--- /dev/null
+++ b/examples/warning/UnusedExplicitImportTypeOp/Lib.purs
@@ -0,0 +1,8 @@
+module Lib where
+
+type Nat f g = ∀ x. f x → g x
+
+infixr 4 type Nat as ~>
+
+natId ∷ ∀ f. f ~> f
+natId x = x
diff --git a/examples/warning/UnusedExplicitImportValOp.purs b/examples/warning/UnusedExplicitImportValOp.purs
new file mode 100644
index 0000000..26a7928
--- /dev/null
+++ b/examples/warning/UnusedExplicitImportValOp.purs
@@ -0,0 +1,8 @@
+-- @shouldWarnWith UnusedExplicitImport
+module Main where
+
+import Prelude (Unit, unit, pure, (+))
+import Control.Monad.Eff (Eff)
+
+main :: Eff () Unit
+main = pure unit
diff --git a/purescript.cabal b/purescript.cabal
index 4c07045..18ce548 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,10 +1,10 @@
name: purescript
-version: 0.10.0
+version: 0.10.1
cabal-version: >=1.8
build-type: Simple
-license: MIT
+license: BSD3
license-file: LICENSE
-copyright: (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
+copyright: (c) 2013-16 Phil Freeman, (c) 2014-16 Gary Burgess
maintainer: Phil Freeman <paf31@cantab.net>
stability: experimental
synopsis: PureScript Programming Language Compiler
@@ -60,6 +60,7 @@ extra-source-files: examples/passing/*.purs
, examples/failing/ConflictingImports2/*.purs
, examples/failing/ConflictingQualifiedImports/*.purs
, examples/failing/ConflictingQualifiedImports2/*.purs
+ , examples/failing/DuplicateModule/*.purs
, examples/failing/ExportConflictClass/*.purs
, examples/failing/ExportConflictCtor/*.purs
, examples/failing/ExportConflictType/*.purs
@@ -76,6 +77,7 @@ extra-source-files: examples/passing/*.purs
, examples/failing/OrphanInstance/*.purs
, examples/warning/*.purs
, examples/warning/*.js
+ , examples/warning/UnusedExplicitImportTypeOp/*.purs
, examples/docs/bower_components/purescript-prelude/src/*.purs
, examples/docs/bower.json
, examples/docs/src/*.purs
@@ -100,7 +102,7 @@ source-repository head
library
build-depends: base >=4.8 && <5,
- aeson >= 0.8 && < 1.1,
+ aeson >= 0.8 && < 1.0,
aeson-better-errors >= 0.8,
ansi-terminal >= 0.6.2 && < 0.7,
base-compat >=0.6.0,
@@ -317,7 +319,7 @@ library
executable psc
build-depends: base >=4 && <5,
purescript -any,
- aeson >= 0.8 && < 1.1,
+ aeson >= 0.8 && < 1.0,
ansi-terminal >= 0.6.2 && < 0.7,
base-compat >=0.6.0,
bytestring -any,
@@ -395,7 +397,7 @@ executable psc-docs
executable psc-publish
build-depends: base >=4 && <5,
purescript -any,
- aeson -any,
+ aeson >= 0.8 && < 1.0,
bytestring -any,
optparse-applicative -any
main-is: Main.hs
@@ -442,7 +444,7 @@ executable psc-ide-server
other-modules: Paths_purescript
other-extensions:
build-depends: base >=4 && <5,
- aeson >= 0.8 && < 1.1,
+ aeson >= 0.8 && < 1.0,
bytestring -any,
purescript -any,
base-compat >=0.6.0,
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 6a68cfa..513d8e0 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -47,7 +47,6 @@ data SimpleErrorMessage
| MultipleValueOpFixities (OpName 'ValueOpName)
| MultipleTypeOpFixities (OpName 'TypeOpName)
| OrphanTypeDeclaration Ident
- | RedefinedModule ModuleName [SourceSpan]
| RedefinedIdent Ident
| OverlappingNamesInLet
| UnknownName (Qualified Name)
@@ -59,7 +58,7 @@ data SimpleErrorMessage
| ScopeShadowing Name (Maybe ModuleName) [ModuleName]
| DeclConflict Name Name
| ExportConflict (Qualified Name) (Qualified Name)
- | DuplicateModuleName ModuleName
+ | DuplicateModule ModuleName [SourceSpan]
| DuplicateTypeArgument String
| InvalidDoBind
| InvalidDoLet
@@ -107,7 +106,7 @@ data SimpleErrorMessage
| MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName)
| ImportHidingModule ModuleName
| UnusedImport ModuleName
- | UnusedExplicitImport ModuleName [String] (Maybe ModuleName) [DeclarationRef]
+ | UnusedExplicitImport ModuleName [Name] (Maybe ModuleName) [DeclarationRef]
| UnusedDctorImport ModuleName (ProperName 'TypeName) (Maybe ModuleName) [DeclarationRef]
| UnusedDctorExplicitImport ModuleName (ProperName 'TypeName) [ProperName 'ConstructorName] (Maybe ModuleName) [DeclarationRef]
| DuplicateSelectiveImport ModuleName
@@ -179,6 +178,10 @@ data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [Decla
getModuleName :: Module -> ModuleName
getModuleName (Module _ _ name _ _) = name
+-- | Return a module's source span.
+getModuleSourceSpan :: Module -> SourceSpan
+getModuleSourceSpan (Module ss _ _ _ _) = ss
+
-- |
-- Add an import declaration for a module if it does not already explicitly import it.
--
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index b176f11..967ccd1 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -90,7 +90,6 @@ errorCode em = case unwrapErrorMessage em of
MultipleValueOpFixities{} -> "MultipleValueOpFixities"
MultipleTypeOpFixities{} -> "MultipleTypeOpFixities"
OrphanTypeDeclaration{} -> "OrphanTypeDeclaration"
- RedefinedModule{} -> "RedefinedModule"
RedefinedIdent{} -> "RedefinedIdent"
OverlappingNamesInLet -> "OverlappingNamesInLet"
UnknownName{} -> "UnknownName"
@@ -102,7 +101,7 @@ errorCode em = case unwrapErrorMessage em of
ScopeShadowing{} -> "ScopeShadowing"
DeclConflict{} -> "DeclConflict"
ExportConflict{} -> "ExportConflict"
- DuplicateModuleName{} -> "DuplicateModuleName"
+ DuplicateModule{} -> "DuplicateModule"
DuplicateTypeArgument{} -> "DuplicateTypeArgument"
InvalidDoBind -> "InvalidDoBind"
InvalidDoLet -> "InvalidDoLet"
@@ -488,10 +487,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
line $ "There are multiple fixity/precedence declarations for type operator " ++ markCode (showOp op)
renderSimpleErrorMessage (OrphanTypeDeclaration nm) =
line $ "The type declaration for " ++ markCode (showIdent nm) ++ " should be followed by its definition."
- renderSimpleErrorMessage (RedefinedModule name filenames) =
- paras [ line ("The module " ++ markCode (runModuleName name) ++ " has been defined multiple times:")
- , indent . paras $ map (line . displaySourceSpan) filenames
- ]
renderSimpleErrorMessage (RedefinedIdent name) =
line $ "The value " ++ markCode (showIdent name) ++ " has been defined multiple times"
renderSimpleErrorMessage (UnknownName name) =
@@ -521,8 +516,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
line $ "Declaration for " ++ printName (Qualified Nothing new) ++ " conflicts with an existing " ++ nameType existing ++ " of the same name."
renderSimpleErrorMessage (ExportConflict new existing) =
line $ "Export for " ++ printName new ++ " conflicts with " ++ runName existing
- renderSimpleErrorMessage (DuplicateModuleName mn) =
- line $ "Module " ++ markCode (runModuleName mn) ++ " has been defined multiple times."
+ renderSimpleErrorMessage (DuplicateModule mn ss) =
+ paras [ line ("Module " ++ markCode (runModuleName mn) ++ " has been defined multiple times:")
+ , indent . paras $ map (line . displaySourceSpan) ss
+ ]
renderSimpleErrorMessage (CycleInDeclaration nm) =
line $ "The value of " ++ markCode (showIdent nm) ++ " is undefined here, so this reference is not allowed."
renderSimpleErrorMessage (CycleInModules mns) =
@@ -760,7 +757,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) =
paras [ line $ "The import of module " ++ markCode (runModuleName mn) ++ " contains the following unused references:"
- , indent $ paras $ map line names
+ , indent $ paras $ map (line . markCode . runName . Qualified Nothing) names
, line "It could be replaced with:"
, indent $ line $ markCode $ showSuggestion msg ]
diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs
index 6bec467..fceea2a 100644
--- a/src/Language/PureScript/Linter/Imports.hs
+++ b/src/Language/PureScript/Linter/Imports.hs
@@ -243,7 +243,7 @@ lintImportDecl env mni qualifierName names declType allowImplicit =
didWarn' <- forM (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do
let allCtors = dctorsForType mni tn
-- If we've not already warned a type is unused, check its data constructors
- unless' (runProperName tn `notElem` usedNames) $
+ unless' (TyName tn `notElem` usedNames) $
case (c, dctors `intersect` allCtors) of
(_, []) | c /= Just [] -> warn (UnusedDctorImport mni tn qualifierName allRefs)
(Just ctors, dctors') ->
@@ -335,18 +335,18 @@ findUsedRefs env mni qn names =
matchName
:: (ProperName 'ConstructorName -> Maybe (ProperName 'TypeName))
-> Name
- -> Maybe String
-matchName _ (IdentName x) = Just $ showIdent x
-matchName _ (TyName x) = Just $ runProperName x
-matchName _ (TyClassName x) = Just $ runProperName x
-matchName lookupDc (DctorName x) = runProperName <$> lookupDc x
-matchName _ _ = Nothing
-
-runDeclRef :: DeclarationRef -> Maybe String
+ -> Maybe Name
+matchName lookupDc (DctorName x) = TyName <$> lookupDc x
+matchName _ ModName{} = Nothing
+matchName _ name = Just name
+
+runDeclRef :: DeclarationRef -> Maybe Name
runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref
-runDeclRef (ValueRef ident) = Just $ showIdent ident
-runDeclRef (TypeRef pn _) = Just $ runProperName pn
-runDeclRef (TypeClassRef pn) = Just $ runProperName pn
+runDeclRef (ValueRef ident) = Just $ IdentName ident
+runDeclRef (ValueOpRef op) = Just $ ValOpName op
+runDeclRef (TypeRef pn _) = Just $ TyName pn
+runDeclRef (TypeOpRef op) = Just $ TyOpName op
+runDeclRef (TypeClassRef pn) = Just $ TyClassName pn
runDeclRef _ = Nothing
checkDuplicateImports
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 5e68831..99d4672 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -40,8 +40,9 @@ import Data.Aeson (encode, decode)
import qualified Data.Aeson as Aeson
import Data.ByteString.Builder (toLazyByteString, stringUtf8)
import Data.Either (partitionEithers)
+import Data.Function (on)
import Data.Foldable (for_)
-import Data.List (foldl', sort)
+import Data.List (foldl', sortBy, groupBy)
import Data.Maybe (fromMaybe, catMaybes)
import Data.String (fromString)
import Data.Time.Clock
@@ -191,18 +192,17 @@ make ma@MakeActions{..} ms = do
where
checkModuleNamesAreUnique :: m ()
checkModuleNamesAreUnique =
- case findDuplicate (map getModuleName ms) of
- Nothing -> return ()
- Just mn -> throwError . errorMessage $ DuplicateModuleName mn
-
- -- Verify that a list of values has unique keys
- findDuplicate :: (Ord a) => [a] -> Maybe a
- findDuplicate = go . sort
- where
- go (x : y : xs)
- | x == y = Just x
- | otherwise = go (y : xs)
- go _ = Nothing
+ for_ (findDuplicates getModuleName ms) $ \mss ->
+ throwError . flip foldMap mss $ \ms' ->
+ let mn = getModuleName (head ms')
+ in errorMessage $ DuplicateModule mn (map getModuleSourceSpan ms')
+
+ -- Find all groups of duplicate values in a list based on a projection.
+ findDuplicates :: Ord b => (a -> b) -> [a] -> Maybe [[a]]
+ findDuplicates f xs =
+ case filter ((> 1) . length) . groupBy ((==) `on` f) . sortBy (compare `on` f) $ xs of
+ [] -> Nothing
+ xss -> Just xss
-- Sort a list so its elements appear in the same order as in another list.
inOrderOf :: (Ord a) => [a] -> [a] -> [a]
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index 1ccd283..2d2a483 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -99,15 +99,12 @@ desugarImportsWithEnv externs modules = do
exportedRefs f = M.fromList $ (, efModuleName) <$> mapMaybe f efExports
updateEnv :: ([Module], Env) -> Module -> m ([Module], Env)
- updateEnv (ms, env) m@(Module ss _ mn _ refs) =
- case mn `M.lookup` env of
- Just m' -> throwError . errorMessage $ RedefinedModule mn [envModuleSourceSpan m', ss]
- Nothing -> do
- members <- findExportable m
- let env' = M.insert mn (ss, primImports, members) env
- (m', imps) <- resolveImports env' m
- exps <- maybe (return members) (resolveExports env' ss mn imps members) refs
- return (m' : ms, M.insert mn (ss, imps, exps) env)
+ updateEnv (ms, env) m@(Module ss _ mn _ refs) = do
+ members <- findExportable m
+ let env' = M.insert mn (ss, primImports, members) env
+ (m', imps) <- resolveImports env' m
+ exps <- maybe (return members) (resolveExports env' ss mn imps members) refs
+ return (m' : ms, M.insert mn (ss, imps, exps) env)
renameInModule' :: Env -> Module -> m Module
renameInModule' env m@(Module _ _ mn _ _) =
diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
index 2dcceef..a833465 100755
--- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternGuards #-}
-- |
-- This module implements the generic deriving elaboration that takes place during desugaring.
@@ -55,10 +56,10 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] Derived
= TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon
deriveInstance mn ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwrappedTy] DerivedInstance)
| className == Qualified (Just dataNewtype) (ProperName "Newtype")
- , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor wrappedTy
+ , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy
, mn == fromMaybe mn mn'
= do
- (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon unwrappedTy
+ (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon args unwrappedTy
return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst)
deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
= throwError . errorMessage $ CannotDerive className tys
@@ -93,12 +94,31 @@ deriveNewtypeInstance className ds tys tyConNm dargs = do
tyCon <- findTypeDecl tyConNm ds
go tyCon
where
- go (DataDeclaration Newtype _ tyArgNames [(_, [wrapped])]) = do
- let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs
- return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped]))
+ go (DataDeclaration Newtype _ tyArgNames [(_, [wrapped])])
+ -- The newtype might not be applied to all type arguments.
+ -- This is okay as long as the newtype wraps something which ends with
+ -- sufficiently many type applications to variables.
+ -- For example, we can derive Functor for
+ --
+ -- newtype MyArray a = MyArray (Array a)
+ --
+ -- since Array a is a type application which uses the last
+ -- type argument
+ | Just wrapped' <- stripRight (takeReverse (length tyArgNames - length dargs) tyArgNames) wrapped =
+ do let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs
+ return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped']))
go (PositionedDeclaration _ _ d) = go d
go _ = throwError . errorMessage $ InvalidNewtypeInstance className tys
+ takeReverse :: Int -> [a] -> [a]
+ takeReverse n = take n . reverse
+
+ stripRight :: [(String, Maybe kind)] -> Type -> Maybe Type
+ stripRight [] ty = Just ty
+ stripRight ((arg, _) : args) (TypeApp t (TypeVar arg'))
+ | arg == arg' = stripRight args t
+ stripRight _ _ = Nothing
+
dataGeneric :: ModuleName
dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]
@@ -427,40 +447,41 @@ deriveNewtype
=> ModuleName
-> [Declaration]
-> ProperName 'TypeName
+ -> [Type]
-> Type
-> m ([Declaration], Type)
-deriveNewtype mn ds tyConNm unwrappedTy = do
- checkIsWildcard unwrappedTy
- go =<< findTypeDecl tyConNm ds
+deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do
+ checkIsWildcard unwrappedTy
+ go =<< findTypeDecl tyConNm ds
where
+ go :: Declaration -> m ([Declaration], Type)
+ go (DataDeclaration Data name _ _) =
+ throwError . errorMessage $ CannotDeriveNewtypeForData name
+ go (DataDeclaration Newtype name args dctors) = do
+ checkNewtype name dctors
+ wrappedIdent <- freshIdent "n"
+ unwrappedIdent <- freshIdent "a"
+ let (ctorName, [ty]) = head dctors
+ inst =
+ [ ValueDeclaration (Ident "wrap") Public [] $ Right $
+ Constructor (Qualified (Just mn) ctorName)
+ , ValueDeclaration (Ident "unwrap") Public [] $ Right $
+ lamCase wrappedIdent
+ [ CaseAlternative
+ [ConstructorBinder (Qualified (Just mn) ctorName) [VarBinder unwrappedIdent]]
+ (Right (Var (Qualified Nothing unwrappedIdent)))
+ ]
+ ]
+ subst = zipWith ((,) . fst) args tyConArgs
+ return (inst, replaceAllTypeVars subst ty)
+ go (PositionedDeclaration _ _ d) = go d
+ go _ = internalError "deriveNewtype go: expected DataDeclaration"
- go :: Declaration -> m ([Declaration], Type)
- go (DataDeclaration Data name _ _) =
- throwError . errorMessage $ CannotDeriveNewtypeForData name
- go (DataDeclaration Newtype name _ dctors) = do
- checkNewtype name dctors
- let (ctorName, [ty]) = head dctors
- wrappedIdent <- freshIdent "n"
- unwrappedIdent <- freshIdent "a"
- let inst =
- [ ValueDeclaration (Ident "wrap") Public [] $ Right $
- Constructor (Qualified (Just mn) ctorName)
- , ValueDeclaration (Ident "unwrap") Public [] $ Right $
- lamCase wrappedIdent
- [ CaseAlternative
- [ConstructorBinder (Qualified (Just mn) ctorName) [VarBinder unwrappedIdent]]
- (Right (Var (Qualified Nothing unwrappedIdent)))
- ]
- ]
- return (inst, ty)
- go (PositionedDeclaration _ _ d) = go d
- go _ = internalError "deriveNewtype go: expected DataDeclaration"
-
- checkIsWildcard :: Type -> m ()
- checkIsWildcard (TypeWildcard _) =
- return ()
- checkIsWildcard _ =
- throwError . errorMessage $ NonWildcardNewtypeInstance tyConNm
+ checkIsWildcard :: Type -> m ()
+ checkIsWildcard (TypeWildcard _) =
+ return ()
+ checkIsWildcard _ =
+ throwError . errorMessage $ NonWildcardNewtypeInstance tyConNm
findTypeDecl
:: (MonadError MultipleErrors m)
diff --git a/src/System/IO/UTF8.hs b/src/System/IO/UTF8.hs
index fe2788f..a69dded 100644
--- a/src/System/IO/UTF8.hs
+++ b/src/System/IO/UTF8.hs
@@ -2,24 +2,13 @@ module System.IO.UTF8 where
import Prelude.Compat
-import System.IO ( IOMode(..)
- , hGetContents
- , hSetEncoding
- , hClose
- , hPutStr
- , openFile
- , utf8
- )
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.UTF8 as UTF8
readUTF8File :: FilePath -> IO String
readUTF8File inFile = do
- h <- openFile inFile ReadMode
- hSetEncoding h utf8
- hGetContents h
+ fmap UTF8.toString (BS.readFile inFile)
writeUTF8File :: FilePath -> String -> IO ()
writeUTF8File inFile text = do
- h <- openFile inFile WriteMode
- hSetEncoding h utf8
- hPutStr h text
- hClose h
+ BS.writeFile inFile (UTF8.fromString text)
diff --git a/stack.yaml b/stack.yaml
index e86fae5..b0e1501 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -2,11 +2,11 @@ resolver: lts-6.13
packages:
- '.'
extra-deps:
-- aeson-1.0.0.0
+# - aeson-1.0.0.0
- http-client-0.5.1
- http-client-tls-0.3.0
- pipes-http-1.0.4
-- semigroups-0.18.2
-flags:
- semigroups:
- bytestring-builder: false
+# - semigroups-0.18.2
+# flags:
+# semigroups:
+# bytestring-builder: false