git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge pull request #1501 from purescript/tempbuild
7e6162fPhil Freeman
LICENSE+167−68
compare with golang
unifiedsplit
@@ -31,6 +31,7 @@ PureScript uses the following Haskell library packages. Their license files foll
31 array
31 array
32 attoparsec
32 attoparsec
33 base
33 base
34+ binary
34 blaze-builder
35 blaze-builder
35 bower-json
36 bower-json
36 boxes
37 boxes
@@ -45,9 +46,10 @@ PureScript uses the following Haskell library packages. Their license files foll
45 haskeline
46 haskeline
46 integer-gmp
47 integer-gmp
47 language-javascript
48 language-javascript
49+ lifted-base
50+ monad-control
48 mtl
51 mtl
49 nats
52 nats
50− old-locale
51 optparse-applicative
53 optparse-applicative
52 parsec
54 parsec
53 pattern-arrows
55 pattern-arrows
@@ -59,12 +61,14 @@ PureScript uses the following Haskell library packages. Their license files foll
59 scientific
61 scientific
60 semigroups
62 semigroups
61 split
63 split
64+ stm
62 syb
65 syb
63 template-haskell
66 template-haskell
64 terminfo
67 terminfo
65 text
68 text
66 time
69 time
67 transformers
70 transformers
71+ transformers-base
68 transformers-compat
72 transformers-compat
69 unix
73 unix
70 unordered-containers
74 unordered-containers
@@ -449,6 +453,39 @@ base LICENSE file:
449
453
450 -----------------------------------------------------------------------------
454 -----------------------------------------------------------------------------
451
455
456+binary LICENSE file:
457+
458+ Copyright (c) Lennart Kolmodin
459+
460+ All rights reserved.
461+
462+ Redistribution and use in source and binary forms, with or without
463+ modification, are permitted provided that the following conditions
464+ are met:
465+
466+ 1. Redistributions of source code must retain the above copyright
467+ notice, this list of conditions and the following disclaimer.
468+
469+ 2. Redistributions in binary form must reproduce the above copyright
470+ notice, this list of conditions and the following disclaimer in the
471+ documentation and/or other materials provided with the distribution.
472+
473+ 3. Neither the name of the author nor the names of his contributors
474+ may be used to endorse or promote products derived from this software
475+ without specific prior written permission.
476+
477+ THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
478+ OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
479+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
480+ DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
481+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
482+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
483+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
484+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
485+ STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
486+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
487+ POSSIBILITY OF SUCH DAMAGE.
488+
452blaze-builder LICENSE file:
489blaze-builder LICENSE file:
453
490
454 Copyright Jasper Van der Jeugt 2010, Simon Meier 2010 & 2011
491 Copyright Jasper Van der Jeugt 2010, Simon Meier 2010 & 2011
@@ -967,6 +1004,70 @@ language-javascript LICENSE file:
967 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
1004 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
968 OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1005 OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
969
1006
1007+lifted-base LICENSE file:
1008+
1009+ Copyright © 2010-2012, Bas van Dijk, Anders Kaseorg
1010+ All rights reserved.
1011+
1012+ Redistribution and use in source and binary forms, with or without
1013+ modification, are permitted provided that the following conditions are
1014+ met:
1015+
1016+ • Redistributions of source code must retain the above copyright
1017+ notice, this list of conditions and the following disclaimer.
1018+
1019+ • Redistributions in binary form must reproduce the above copyright
1020+ notice, this list of conditions and the following disclaimer in the
1021+ documentation and/or other materials provided with the distribution.
1022+
1023+ • Neither the name of the author nor the names of other contributors
1024+ may be used to endorse or promote products derived from this
1025+ software without specific prior written permission.
1026+
1027+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
1028+ “AS IS” AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
1029+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
1030+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
1031+ HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
1032+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
1033+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
1034+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
1035+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
1036+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
1037+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1038+
1039+monad-control LICENSE file:
1040+
1041+ Copyright © 2010, Bas van Dijk, Anders Kaseorg
1042+ All rights reserved.
1043+
1044+ Redistribution and use in source and binary forms, with or without
1045+ modification, are permitted provided that the following conditions are
1046+ met:
1047+
1048+ • Redistributions of source code must retain the above copyright
1049+ notice, this list of conditions and the following disclaimer.
1050+
1051+ • Redistributions in binary form must reproduce the above copyright
1052+ notice, this list of conditions and the following disclaimer in the
1053+ documentation and/or other materials provided with the distribution.
1054+
1055+ • Neither the name of the author nor the names of other contributors
1056+ may be used to endorse or promote products derived from this
1057+ software without specific prior written permission.
1058+
1059+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
1060+ “AS IS” AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
1061+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
1062+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
1063+ HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
1064+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
1065+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
1066+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
1067+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
1068+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
1069+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1070+
970mtl LICENSE file:
1071mtl LICENSE file:
971
1072
972 The Glasgow Haskell Compiler License
1073 The Glasgow Haskell Compiler License
@@ -1034,72 +1135,6 @@ nats LICENSE file:
1034 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
1135 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
1035 POSSIBILITY OF SUCH DAMAGE.
1136 POSSIBILITY OF SUCH DAMAGE.
1036
1137
1037−old-locale LICENSE file:
1038−
1039− This library (libraries/base) is derived from code from two
1040− sources:
1041−
1042− * Code from the GHC project which is largely (c) The University of
1043− Glasgow, and distributable under a BSD-style license (see below),
1044−
1045− * Code from the Haskell 98 Report which is (c) Simon Peyton Jones
1046− and freely redistributable (but see the full license for
1047− restrictions).
1048−
1049− The full text of these licenses is reproduced below. Both of the
1050− licenses are BSD-style or compatible.
1051−
1052− -----------------------------------------------------------------------------
1053−
1054− The Glasgow Haskell Compiler License
1055−
1056− Copyright 2004, The University Court of the University of Glasgow.
1057− All rights reserved.
1058−
1059− Redistribution and use in source and binary forms, with or without
1060− modification, are permitted provided that the following conditions are met:
1061−
1062− - Redistributions of source code must retain the above copyright notice,
1063− this list of conditions and the following disclaimer.
1064−
1065− - Redistributions in binary form must reproduce the above copyright notice,
1066− this list of conditions and the following disclaimer in the documentation
1067− and/or other materials provided with the distribution.
1068−
1069− - Neither name of the University nor the names of its contributors may be
1070− used to endorse or promote products derived from this software without
1071− specific prior written permission.
1072−
1073− THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
1074− GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
1075− INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
1076− FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
1077− UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
1078− FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
1079− DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
1080− SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
1081− CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
1082− LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
1083− OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
1084− DAMAGE.
1085−
1086− -----------------------------------------------------------------------------
1087−
1088− Code derived from the document "Report on the Programming Language
1089− Haskell 98", is distributed under the following license:
1090−
1091− Copyright (c) 2002 Simon Peyton Jones
1092−
1093− The authors intend this Report to belong to the entire Haskell
1094− community, and so we grant permission to copy and distribute it for
1095− any purpose, provided that it is reproduced in its entirety,
1096− including this Notice. Modified versions of this Report may also be
1097− copied and distributed for any purpose, provided that the modified
1098− version is clearly presented as such, and that it does not claim to
1099− be a definition of the Haskell 98 Language.
1100−
1101− -----------------------------------------------------------------------------
1102−
1103optparse-applicative LICENSE file:
1138optparse-applicative LICENSE file:
1104
1139
1105 Copyright (c) 2012, Paolo Capriotti
1140 Copyright (c) 2012, Paolo Capriotti
@@ -1450,6 +1485,40 @@ split LICENSE file:
1450 OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
1485 OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
1451 SUCH DAMAGE.
1486 SUCH DAMAGE.
1452
1487
1488+stm LICENSE file:
1489+
1490+ The Glasgow Haskell Compiler License
1491+
1492+ Copyright 2004, The University Court of the University of Glasgow.
1493+ All rights reserved.
1494+
1495+ Redistribution and use in source and binary forms, with or without
1496+ modification, are permitted provided that the following conditions are met:
1497+
1498+ - Redistributions of source code must retain the above copyright notice,
1499+ this list of conditions and the following disclaimer.
1500+
1501+ - Redistributions in binary form must reproduce the above copyright notice,
1502+ this list of conditions and the following disclaimer in the documentation
1503+ and/or other materials provided with the distribution.
1504+
1505+ - Neither name of the University nor the names of its contributors may be
1506+ used to endorse or promote products derived from this software without
1507+ specific prior written permission.
1508+
1509+ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
1510+ GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
1511+ INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
1512+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
1513+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
1514+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
1515+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
1516+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
1517+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
1518+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
1519+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
1520+ DAMAGE.
1521+
1453syb LICENSE file:
1522syb LICENSE file:
1454
1523
1455 This library (libraries/syb) is derived from code from several
1524 This library (libraries/syb) is derived from code from several
@@ -1674,6 +1743,36 @@ transformers LICENSE file:
1674 OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
1743 OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
1675 DAMAGE.
1744 DAMAGE.
1676
1745
1746+transformers-base LICENSE file:
1747+
1748+ Copyright (c) 2011, Mikhail Vorozhtsov, Bas van Dijk
1749+ All rights reserved.
1750+
1751+ Redistribution and use in source and binary forms, with or without
1752+ modification, are permitted provided that the following conditions are met:
1753+
1754+ - Redistributions of source code must retain the above copyright notice,
1755+ this list of conditions and the following disclaimer.
1756+ - Redistributions in binary form must reproduce the above copyright
1757+ notice, this list of conditions and the following disclaimer in the
1758+ documentation and/or other materials provided with the distribution.
1759+ - Neither the names of the copyright owners nor the names of the
1760+ contributors may be used to endorse or promote products derived
1761+ from this software without specific prior written permission.
1762+
1763+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
1764+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
1765+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
1766+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
1767+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
1768+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
1769+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
1770+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
1771+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
1772+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
1773+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1774+
1775+
1677transformers-compat LICENSE file:
1776transformers-compat LICENSE file:
1678
1777
1679 Copyright 2012 Edward Kmett
1778 Copyright 2012 Edward Kmett
@@ -1836,7 +1935,7 @@ vector LICENSE file:
1836
1935
1837void LICENSE file:
1936void LICENSE file:
1838
1937
1839− Copyright 2013 Edward Kmett
1938+ Copyright 2015 Edward Kmett
1840
1939
1841 All rights reserved.
1940 All rights reserved.
1842
1941
license-generator/generate+3
@@ -9,6 +9,9 @@ set -e # exit on error
9set -u # exit on undefined variable
9set -u # exit on undefined variable
10set -o pipefail # propagate nonzero exit codes through pipelines
10set -o pipefail # propagate nonzero exit codes through pipelines
11
11
12+export LC_CTYPE=C
13+export LANG=C
14+
12if ! which cabal-dependency-licenses >/dev/null; then
15if ! which cabal-dependency-licenses >/dev/null; then
13 echo "$0: the program 'cabal-dependency-licenses' is required." >&2
16 echo "$0: the program 'cabal-dependency-licenses' is required." >&2
14 echo "$0: see Hackage: https://hackage.haskell.org/package/cabal-dependency-licenses" >&2
17 echo "$0: see Hackage: https://hackage.haskell.org/package/cabal-dependency-licenses" >&2
psci/PSCi.hs+4−4
@@ -263,10 +263,10 @@ makeIO f io = do
263
263
264make :: PSCiState -> [(Either P.RebuildPolicy FilePath, P.Module)] -> P.Make P.Environment
264make :: PSCiState -> [(Either P.RebuildPolicy FilePath, P.Module)] -> P.Make P.Environment
265make PSCiState{..} ms = P.make actions' (map snd (psciLoadedModules ++ ms))
265make PSCiState{..} ms = P.make actions' (map snd (psciLoadedModules ++ ms))
266− where
266+ where
267− filePathMap = M.fromList $ (first P.getModuleName . swap) `map` (psciLoadedModules ++ ms)
267+ filePathMap = M.fromList $ (first P.getModuleName . swap) `map` (psciLoadedModules ++ ms)
268− actions = P.buildMakeActions modulesDir filePathMap psciForeignFiles False
268+ actions = P.buildMakeActions modulesDir filePathMap psciForeignFiles False
269− actions' = actions { P.progress = const (return ()) }
269+ actions' = actions { P.progress = const (return ()) }
270
270
271-- |
271-- |
272-- Takes a value declaration and evaluates it with the current state.
272-- Takes a value declaration and evaluates it with the current state.
purescript.cabal+4−1
@@ -32,6 +32,9 @@ source-repository head
32
32
33library
33library
34 build-depends: base >=4.6 && <5,
34 build-depends: base >=4.6 && <5,
35+ lifted-base >= 0.2.3 && < 0.2.4,
36+ monad-control >= 1.0.0.0 && < 1.1,
37+ transformers-base >= 0.4.0 && < 0.5,
35 containers -any,
38 containers -any,
36 unordered-containers -any,
39 unordered-containers -any,
37 dlist -any,
40 dlist -any,
@@ -176,7 +179,7 @@ executable psc
176 main-is: Main.hs
179 main-is: Main.hs
177 buildable: True
180 buildable: True
178 hs-source-dirs: psc
181 hs-source-dirs: psc
179− ghc-options: -Wall -O2 -fno-warn-unused-do-bind
182+ ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N"
180
183
181executable psci
184executable psci
182 build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
185 build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
src/Language/PureScript/AST/Traversals.hs+3−3
@@ -216,10 +216,10 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
216 f' d = f d
216 f' d = f d
217
217
218 g' v@(UnaryMinus v1) = g v <> g' v1
218 g' v@(UnaryMinus v1) = g v <> g' v1
219− g' v@(BinaryNoParens op v1 v2) = g v <> g op <> g' v1 <> g' v2
219+ g' v@(BinaryNoParens op v1 v2) = g v <> g' op <> g' v1 <> g' v2
220 g' v@(Parens v1) = g v <> g' v1
220 g' v@(Parens v1) = g v <> g' v1
221− g' v@(OperatorSection op (Left v1)) = g v <> g op <> g' v1
221+ g' v@(OperatorSection op (Left v1)) = g v <> g' op <> g' v1
222− g' v@(OperatorSection op (Right v1)) = g v <> g op <> g' v1
222+ g' v@(OperatorSection op (Right v1)) = g v <> g' op <> g' v1
223 g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)
223 g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)
224 g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)
224 g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)
225 g' v@(ObjectConstructor vs) = foldl (<>) (g v) (map g' (mapMaybe snd vs))
225 g' v@(ObjectConstructor vs) = foldl (<>) (g v) (map g' (mapMaybe snd vs))
src/Language/PureScript/Docs/Convert.hs−1
@@ -166,7 +166,6 @@ convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) tit
166 unQual x = let (P.Qualified _ y) = x in P.runProperName y
166 unQual x = let (P.Qualified _ y) = x in P.runProperName y
167
167
168 extractProperNames (P.TypeConstructor n) = [unQual n]
168 extractProperNames (P.TypeConstructor n) = [unQual n]
169− extractProperNames (P.SaturatedTypeSynonym n _) = [unQual n]
170 extractProperNames _ = []
169 extractProperNames _ = []
171
170
172 childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)
171 childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)
src/Language/PureScript/Errors.hs+4
@@ -98,6 +98,7 @@ data SimpleErrorMessage
98 | CtorConflictsWithClass ProperName
98 | CtorConflictsWithClass ProperName
99 | ClassConflictsWithType ProperName
99 | ClassConflictsWithType ProperName
100 | ClassConflictsWithCtor ProperName
100 | ClassConflictsWithCtor ProperName
101+ | DuplicateModuleName ModuleName
101 | DuplicateClassExport ProperName
102 | DuplicateClassExport ProperName
102 | DuplicateValueExport Ident
103 | DuplicateValueExport Ident
103 | DuplicateTypeArgument String
104 | DuplicateTypeArgument String
@@ -237,6 +238,7 @@ errorCode em = case unwrapErrorMessage em of
237 CtorConflictsWithClass{} -> "CtorConflictsWithClass"
238 CtorConflictsWithClass{} -> "CtorConflictsWithClass"
238 ClassConflictsWithType{} -> "ClassConflictsWithType"
239 ClassConflictsWithType{} -> "ClassConflictsWithType"
239 ClassConflictsWithCtor{} -> "ClassConflictsWithCtor"
240 ClassConflictsWithCtor{} -> "ClassConflictsWithCtor"
241+ DuplicateModuleName{} -> "DuplicateModuleName"
240 DuplicateClassExport{} -> "DuplicateClassExport"
242 DuplicateClassExport{} -> "DuplicateClassExport"
241 DuplicateValueExport{} -> "DuplicateValueExport"
243 DuplicateValueExport{} -> "DuplicateValueExport"
242 DuplicateTypeArgument{} -> "DuplicateTypeArgument"
244 DuplicateTypeArgument{} -> "DuplicateTypeArgument"
@@ -505,6 +507,8 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir
505 line $ "Type class " ++ runProperName nm ++ " conflicts with type declaration of the same name"
507 line $ "Type class " ++ runProperName nm ++ " conflicts with type declaration of the same name"
506 renderSimpleErrorMessage (ClassConflictsWithCtor nm) =
508 renderSimpleErrorMessage (ClassConflictsWithCtor nm) =
507 line $ "Type class " ++ runProperName nm ++ " conflicts with data constructor declaration of the same name"
509 line $ "Type class " ++ runProperName nm ++ " conflicts with data constructor declaration of the same name"
510+ renderSimpleErrorMessage (DuplicateModuleName mn) =
511+ line $ "Module " ++ runModuleName mn ++ " has been defined multiple times."
508 renderSimpleErrorMessage (DuplicateClassExport nm) =
512 renderSimpleErrorMessage (DuplicateClassExport nm) =
509 line $ "Duplicate export declaration for type class " ++ runProperName nm
513 line $ "Duplicate export declaration for type class " ++ runProperName nm
510 renderSimpleErrorMessage (DuplicateValueExport nm) =
514 renderSimpleErrorMessage (DuplicateValueExport nm) =
src/Language/PureScript/Make.hs+119−59
@@ -19,6 +19,8 @@
19{-# LANGUAGE RankNTypes #-}
19{-# LANGUAGE RankNTypes #-}
20{-# LANGUAGE RecordWildCards #-}
20{-# LANGUAGE RecordWildCards #-}
21{-# LANGUAGE ScopedTypeVariables #-}
21{-# LANGUAGE ScopedTypeVariables #-}
22+{-# LANGUAGE MultiParamTypeClasses #-}
23+{-# LANGUAGE TypeFamilies #-}
22{-# LANGUAGE CPP #-}
24{-# LANGUAGE CPP #-}
23
25
24module Language.PureScript.Make
26module Language.PureScript.Make
@@ -39,29 +41,31 @@ module Language.PureScript.Make
39#if __GLASGOW_HASKELL__ < 710
41#if __GLASGOW_HASKELL__ < 710
40import Control.Applicative
42import Control.Applicative
41#endif
43#endif
42−import Control.Arrow ((&&&))
43import Control.Monad
44import Control.Monad
44import Control.Monad.Error.Class (MonadError(..))
45import Control.Monad.Error.Class (MonadError(..))
45import Control.Monad.Trans.Except
46import Control.Monad.Trans.Except
46import Control.Monad.Reader
47import Control.Monad.Reader
47import Control.Monad.Writer.Strict
48import Control.Monad.Writer.Strict
48import Control.Monad.Supply
49import Control.Monad.Supply
50+import Control.Monad.Base (MonadBase(..))
51+import Control.Monad.Trans.Control (MonadBaseControl(..))
49
52
50−import Data.Function (on)
53+import Control.Concurrent.Lifted as C
51−import Data.Either (partitionEithers)
54+
52−import Data.List (sortBy, groupBy, foldl')
55+import Data.List (foldl', sort)
53−import Data.Maybe (fromMaybe)
56+import Data.Maybe (fromMaybe, catMaybes)
54import Data.Time.Clock
57import Data.Time.Clock
55import Data.String (fromString)
58import Data.String (fromString)
56import Data.Foldable (for_)
59import Data.Foldable (for_)
57#if __GLASGOW_HASKELL__ < 710
60#if __GLASGOW_HASKELL__ < 710
58import Data.Traversable (traverse)
61import Data.Traversable (traverse)
59#endif
62#endif
63+import Data.Traversable (for)
60import Data.Version (showVersion)
64import Data.Version (showVersion)
61import Data.Aeson (encode, decode)
65import Data.Aeson (encode, decode)
62import qualified Data.ByteString.Lazy as B
66import qualified Data.ByteString.Lazy as B
63−import qualified Data.Map as M
64import qualified Data.Set as S
67import qualified Data.Set as S
68+import qualified Data.Map as M
65
69
66import System.Directory
70import System.Directory
67 (doesFileExist, getModificationTime, createDirectoryIfMissing)
71 (doesFileExist, getModificationTime, createDirectoryIfMissing)
@@ -150,65 +154,113 @@ data RebuildPolicy
150-- If timestamps have not changed, the externs file can be used to provide the module's types without
154-- If timestamps have not changed, the externs file can be used to provide the module's types without
151-- having to typecheck the module again.
155-- having to typecheck the module again.
152--
156--
153−make :: forall m. (Functor m, Applicative m, Monad m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
157+make :: forall m. (Functor m, Applicative m, Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
154 => MakeActions m
158 => MakeActions m
155 -> [Module]
159 -> [Module]
156 -> m Environment
160 -> m Environment
157make MakeActions{..} ms = do
161make MakeActions{..} ms = do
162+ checkModuleNamesAreUnique
163+
158− (sorted, graph) <- sortModules $ map importPrim ms
164+ (sorted, graph) <- sortModules ms
159− toRebuild <- foldM (\s (Module _ _ moduleName' _ _) -> do
165+
160− inputTimestamp <- getInputTimestamp moduleName'
166+ barriers <- zip (map getModuleName sorted) <$> replicateM (length ms) ((,) <$> C.newEmptyMVar <*> C.newEmptyMVar)
161− outputTimestamp <- getOutputTimestamp moduleName'
167+
162− return $ case (inputTimestamp, outputTimestamp) of
168+ for_ sorted $ \m -> fork $ do
163− (Right (Just t1), Just t2) | t1 < t2 -> s
169+ let deps = fromMaybe (error "make: module not found in dependency graph.") (lookup (getModuleName m) graph)
164− (Left RebuildNever, Just _) -> s
170+ buildModule barriers (importPrim m) (deps `inOrderOf` map getModuleName sorted)
165− _ -> S.insert moduleName' s) S.empty sorted
171+
166−
172+ -- Wait for all threads to complete, and collect errors.
167− (externs, toBuild) <- partitionEithers <$> rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
173+ errors <- catMaybes <$> for barriers (takeMVar . snd . snd)
168− for_ toBuild lint
174+
169− (desugared, nextVar) <- runSupplyT 0 $ desugar externs toBuild
175+ -- All threads have completed, rethrow any caught errors.
176+ unless (null errors) $ throwError (mconcat errors)
177+
178+ -- Bundle up all the externs and return them as an Environment
179+ externs <- sequence <$> for barriers (takeMVar . fst . snd)
170− let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
180+ return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment (fromMaybe (error "make: externs were missing but no errors reported.") externs)
171− evalSupplyT nextVar $ go env desugared
172− where
173
181
174− go :: Environment -> [Module] -> SupplyT m Environment
175− go env [] = return env
176− go env (m@(Module ss coms moduleName' _ exps) : ms') = do
177− lift . progress $ CompilingModule moduleName'
178− (checked@(Module _ _ _ elaborated _), env') <- lift . runCheck' env $ typeCheckModule Nothing m
179− checkExhaustiveModule env' checked
180− regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated
181− let mod' = Module ss coms moduleName' regrouped exps
182− corefn = CF.moduleToCoreFn env' mod'
183− [renamed] = renameInModules [corefn]
184− exts = encode $ moduleToExternsFile mod' env'
185− codegen renamed env' exts
186− go env' ms'
187−
188− rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [Either ExternsFile Module]
189− rebuildIfNecessary graph = rebuildIfNecessary'
190− where
191− rebuildIfNecessary' :: S.Set ModuleName -> [Module] -> m [Either ExternsFile Module]
192− rebuildIfNecessary' _ [] = return []
193− rebuildIfNecessary' toRebuild (m@(Module _ _ moduleName' _ _) : ms')
194− | moduleName' `S.member` toRebuild = rebuild toRebuild m moduleName' ms'
195− rebuildIfNecessary' toRebuild (m@(Module _ _ moduleName' _ _) : ms') = do
196− (_, externsJson) <- readExterns moduleName'
197− case decode externsJson of
198− Just externs
199− | efVersion externs == showVersion Paths.version -> (Left externs :) <$> rebuildIfNecessary' toRebuild ms'
200− _ -> rebuild toRebuild m moduleName' ms'
201−
202− rebuild :: S.Set ModuleName -> Module -> ModuleName -> [Module] -> m [Either ExternsFile Module]
203− rebuild toRebuild m moduleName ms' = do
204− let deps = fromMaybe [] $ moduleName `M.lookup` graph
205− (Right m :) <$> rebuildIfNecessary' (toRebuild `S.union` S.fromList deps) ms'
206−
207−reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
208−reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
209 where
182 where
210− combine :: (Ord a) => [(a, b)] -> M.Map a [b]
183+ checkModuleNamesAreUnique :: m ()
211− combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
184+ checkModuleNamesAreUnique =
185+ case findDuplicate (map getModuleName ms) of
186+ Nothing -> return ()
187+ Just mn -> throwError . errorMessage $ DuplicateModuleName mn
188+
189+ -- Verify that a list of values has unique keys
190+ findDuplicate :: (Ord a) => [a] -> Maybe a
191+ findDuplicate = go . sort
192+ where
193+ go (x : y : xs)
194+ | x == y = Just x
195+ | otherwise = go (y : xs)
196+ go _ = Nothing
197+
198+ -- Sort a list so its elements appear in the same order as in another list.
199+ inOrderOf :: (Ord a) => [a] -> [a] -> [a]
200+ inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys
201+
202+ buildModule :: [(ModuleName, (C.MVar (Maybe ExternsFile), C.MVar (Maybe MultipleErrors)))] -> Module -> [ModuleName] -> m ()
203+ buildModule barriers m@(Module _ _ moduleName _ _) deps = flip catchError (markComplete Nothing . Just) $ do
204+ -- We need to wait for dependencies to be built, before checking if the current
205+ -- module should be rebuilt, so the first thing to do is to wait on the
206+ -- MVars for the module's dependencies.
207+ mexterns <- sequence <$> mapM (readMVar . fst . fromMaybe (error "make: no barrier") . flip lookup barriers) deps
208+
209+ outputTimestamp <- getOutputTimestamp moduleName
210+ dependencyTimestamp <- maximumMaybe <$> mapM (fmap shouldExist . getOutputTimestamp) deps
211+ inputTimestamp <- getInputTimestamp moduleName
212+
213+ let shouldRebuild = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of
214+ (Right (Just t1), Just t3, Just t2) -> t1 > t2 || t3 > t2
215+ (Right (Just t1), Nothing, Just t2) -> t1 > t2
216+ (Left RebuildNever, _, Just _) -> False
217+ _ -> True
218+
219+ let rebuild =
220+ case mexterns of
221+ Just externs -> do
222+ progress $ CompilingModule moduleName
223+ let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
224+ lint m
225+ ([desugared], nextVar) <- runSupplyT 0 $ desugar externs [m]
226+ (checked@(Module ss coms _ elaborated exps), env') <- runCheck' env $ typeCheckModule desugared
227+ checkExhaustiveModule env' checked
228+ regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated
229+ let mod' = Module ss coms moduleName regrouped exps
230+ corefn = CF.moduleToCoreFn env' mod'
231+ [renamed] = renameInModules [corefn]
232+ exts = moduleToExternsFile mod' env'
233+ evalSupplyT nextVar $ codegen renamed env' $ encode exts
234+ markComplete (Just exts) Nothing
235+ Nothing -> markComplete Nothing Nothing
236+
237+ if shouldRebuild
238+ then rebuild
239+ else do
240+ mexts <- decodeExterns . snd <$> readExterns moduleName
241+ case mexts of
242+ Just exts -> markComplete (Just exts) Nothing
243+ Nothing -> rebuild
244+ where
245+ markComplete :: Maybe ExternsFile -> Maybe MultipleErrors -> m ()
246+ markComplete externs errors = do
247+ putMVar (fst $ fromMaybe (error "make: no barrier") $ lookup moduleName barriers) externs
248+ putMVar (snd $ fromMaybe (error "make: no barrier") $ lookup moduleName barriers) errors
249+
250+ maximumMaybe :: (Ord a) => [a] -> Maybe a
251+ maximumMaybe [] = Nothing
252+ maximumMaybe xs = Just $ maximum xs
253+
254+ -- Make sure a dependency exists
255+ shouldExist :: Maybe UTCTime -> UTCTime
256+ shouldExist (Just t) = t
257+ shouldExist _ = error "make: dependency should already have been built."
258+
259+ decodeExterns :: B.ByteString -> Maybe ExternsFile
260+ decodeExterns bs = do
261+ externs <- decode bs
262+ guard $ efVersion externs == showVersion Paths.version
263+ return externs
212
264
213-- |
265-- |
214-- Add an import declaration for a module if it does not already explicitly import it.
266-- Add an import declaration for a module if it does not already explicitly import it.
@@ -231,6 +283,14 @@ importPrim = addDefaultImport (ModuleName [ProperName C.prim])
231newtype Make a = Make { unMake :: ReaderT Options (WriterT MultipleErrors (ExceptT MultipleErrors IO)) a }
283newtype Make a = Make { unMake :: ReaderT Options (WriterT MultipleErrors (ExceptT MultipleErrors IO)) a }
232 deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
284 deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
233
285
286+instance MonadBase IO Make where
287+ liftBase = liftIO
288+
289+instance MonadBaseControl IO Make where
290+ type StM Make a = Either MultipleErrors (a, MultipleErrors)
291+ liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake)
292+ restoreM = Make . restoreM
293+
234-- |
294-- |
235-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
295-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
236--
296--
src/Language/PureScript/ModuleDependencies.hs+9−7
@@ -23,20 +23,17 @@ import Control.Monad.Error.Class (MonadError(..))
23
23
24import Data.Graph
24import Data.Graph
25import Data.List (nub)
25import Data.List (nub)
26−import Data.Maybe (mapMaybe)
26+import Data.Maybe (fromMaybe, mapMaybe)
27
27
28import Language.PureScript.AST
28import Language.PureScript.AST
29import Language.PureScript.Names
29import Language.PureScript.Names
30import Language.PureScript.Types
30import Language.PureScript.Types
31import Language.PureScript.Errors
31import Language.PureScript.Errors
32
32
33−-- |
34−-- A list of modules with their dependencies
33+-- | A list of modules with their transitive dependencies
35−--
36type ModuleGraph = [(ModuleName, [ModuleName])]
34type ModuleGraph = [(ModuleName, [ModuleName])]
37
35
38−-- |
39−-- Sort a collection of modules based on module dependencies.
36+-- | Sort a collection of modules based on module dependencies.
40--
37--
41-- Reports an error if the module graph contains a cycle.
38-- Reports an error if the module graph contains a cycle.
42--
39--
@@ -44,7 +41,12 @@ sortModules :: (MonadError MultipleErrors m) => [Module] -> m ([Module], ModuleG
44sortModules ms = do
41sortModules ms = do
45 let verts = map (\m@(Module _ _ _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms
42 let verts = map (\m@(Module _ _ _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms
46 ms' <- mapM toModule $ stronglyConnComp verts
43 ms' <- mapM toModule $ stronglyConnComp verts
44+ let (graph, fromVertex, toVertex) = graphFromEdges verts
47− let moduleGraph = map (\(_, mn, deps) -> (mn, deps)) verts
45+ moduleGraph = do (_, mn, _) <- verts
46+ let v = fromMaybe (error "sortModules: vertex not found") (toVertex mn)
47+ deps = reachable graph v
48+ toKey i = case fromVertex i of (_, key, _) -> key
49+ return (mn, filter (/= mn) (map toKey deps))
48 return (ms', moduleGraph)
50 return (ms', moduleGraph)
49
51
50-- |
52-- |
src/Language/PureScript/Sugar/Names.hs−1
@@ -207,7 +207,6 @@ renameInModule env imports (Module ss coms mn decls exps) =
207 where
207 where
208 updateType :: Type -> m Type
208 updateType :: Type -> m Type
209 updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos
209 updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos
210− updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name pos <*> pure tys
211 updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t
210 updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t
212 updateType t = return t
211 updateType t = return t
213
212
src/Language/PureScript/TypeChecker.hs+8−8
@@ -132,8 +132,8 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms
132--
132--
133-- * Process module imports
133-- * Process module imports
134--
134--
135−typeCheckAll :: Maybe ModuleName -> ModuleName -> [DeclarationRef] -> [Declaration] -> Check [Declaration]
135+typeCheckAll :: ModuleName -> [DeclarationRef] -> [Declaration] -> Check [Declaration]
136−typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds
136+typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds
137 where
137 where
138 go :: Declaration -> Check Declaration
138 go :: Declaration -> Check Declaration
139 go (DataDeclaration dtype name args dctors) = do
139 go (DataDeclaration dtype name args dctors) = do
@@ -181,7 +181,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix
181 go (ValueDeclaration name nameKind [] (Right val)) =
181 go (ValueDeclaration name nameKind [] (Right val)) =
182 warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do
182 warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do
183 valueIsNotDefined moduleName name
183 valueIsNotDefined moduleName name
184− [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
184+ [(_, (val', ty))] <- typesOf moduleName [(name, val)]
185 addValue moduleName name ty nameKind
185 addValue moduleName name ty nameKind
186 return $ ValueDeclaration name nameKind [] $ Right val'
186 return $ ValueDeclaration name nameKind [] $ Right val'
187 go (ValueDeclaration{}) = error "Binders were not desugared"
187 go (ValueDeclaration{}) = error "Binders were not desugared"
@@ -189,7 +189,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix
189 warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do
189 warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do
190 forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
190 forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
191 valueIsNotDefined moduleName name
191 valueIsNotDefined moduleName name
192− tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
192+ tys <- typesOf moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
193 vals' <- forM [ (name, val, nameKind, ty)
193 vals' <- forM [ (name, val, nameKind, ty)
194 | (name, nameKind, _) <- vals
194 | (name, nameKind, _) <- vals
195 , (name', (val, ty)) <- tys
195 , (name', (val, ty)) <- tys
@@ -267,11 +267,11 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix
267-- Type check an entire module and ensure all types and classes defined within the module that are
267-- Type check an entire module and ensure all types and classes defined within the module that are
268-- required by exported members are also exported.
268-- required by exported members are also exported.
269--
269--
270−typeCheckModule :: Maybe ModuleName -> Module -> Check Module
270+typeCheckModule :: Module -> Check Module
271−typeCheckModule _ (Module _ _ _ _ Nothing) = error "exports should have been elaborated"
271+typeCheckModule (Module _ _ _ _ Nothing) = error "exports should have been elaborated"
272−typeCheckModule mainModuleName (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do
272+typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do
273 modify (\s -> s { checkCurrentModule = Just mn })
273 modify (\s -> s { checkCurrentModule = Just mn })
274− decls' <- typeCheckAll mainModuleName mn exps decls
274+ decls' <- typeCheckAll mn exps decls
275 forM_ exps $ \e -> do
275 forM_ exps $ \e -> do
276 checkTypesAreExported e
276 checkTypesAreExported e
277 checkClassMembersAreExported e
277 checkClassMembersAreExported e
src/Language/PureScript/TypeChecker/Entailment.hs+15−24
@@ -37,10 +37,8 @@ import Control.Monad.Writer.Class (tell)
37
37
38import Language.PureScript.AST
38import Language.PureScript.AST
39import Language.PureScript.Errors
39import Language.PureScript.Errors
40−import Language.PureScript.Environment
41import Language.PureScript.Names
40import Language.PureScript.Names
42import Language.PureScript.TypeChecker.Monad
41import Language.PureScript.TypeChecker.Monad
43−import Language.PureScript.TypeChecker.Synonyms
44import Language.PureScript.TypeChecker.Unify
42import Language.PureScript.TypeChecker.Unify
45import Language.PureScript.TypeClassDictionaries
43import Language.PureScript.TypeClassDictionaries
46import Language.PureScript.Types
44import Language.PureScript.Types
@@ -50,8 +48,8 @@ import qualified Language.PureScript.Constants as C
50-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
48-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
51-- return a type class dictionary reference.
49-- return a type class dictionary reference.
52--
50--
53−entails :: Environment -> ModuleName -> M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) -> Constraint -> Check Expr
51+entails :: ModuleName -> M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) -> Constraint -> Check Expr
54−entails env moduleName context = solve
52+entails moduleName context = solve
55 where
53 where
56 forClassName :: Qualified ProperName -> [Type] -> [TypeClassDictionaryInScope]
54 forClassName :: Qualified ProperName -> [Type] -> [TypeClassDictionaryInScope]
57 forClassName cn@(Qualified (Just mn) _) tys = concatMap (findDicts cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))
55 forClassName cn@(Qualified (Just mn) _) tys = concatMap (findDicts cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))
@@ -74,14 +72,10 @@ entails env moduleName context = solve
74 go :: Int -> Qualified ProperName -> [Type] -> Check DictionaryValue
72 go :: Int -> Qualified ProperName -> [Type] -> Check DictionaryValue
75 go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'
73 go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'
76 go work className' tys' = do
74 go work className' tys' = do
77− -- We need to desugar synonyms here so that forClassName can find the correct modules
78− -- in types hidden inside the synonyms.
79− -- TODO: this can go away when synonyms get desugared up front.
80− tys'' <- mapM expandAllTypeSynonyms tys'
81 let instances = do
75 let instances = do
82− tcd <- forClassName className' tys''
76+ tcd <- forClassName className' tys'
83 -- Make sure the type unifies with the type in the type instance definition
77 -- Make sure the type unifies with the type in the type instance definition
84− subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys'' (tcdInstanceTypes tcd)
78+ subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName) tys' (tcdInstanceTypes tcd)
85 return (subst, tcd)
79 return (subst, tcd)
86 (subst, tcd) <- unique instances
80 (subst, tcd) <- unique instances
87 -- Solve any necessary subgoals
81 -- Solve any necessary subgoals
@@ -139,7 +133,7 @@ entails env moduleName context = solve
139 verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]
133 verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]
140 verifySubstitution subst = do
134 verifySubstitution subst = do
141 let grps = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ subst
135 let grps = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ subst
142− guard (all (pairwise (unifiesWith env) . map snd) grps)
136+ guard (all (pairwise unifiesWith . map snd) grps)
143 return $ map head grps
137 return $ map head grps
144
138
145 valUndefined :: Expr
139 valUndefined :: Expr
@@ -149,24 +143,21 @@ entails env moduleName context = solve
149-- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup),
143-- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup),
150-- and return a substitution from type variables to types which makes the type heads unify.
144-- and return a substitution from type variables to types which makes the type heads unify.
151--
145--
152−typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]
146+typeHeadsAreEqual :: ModuleName -> Type -> Type -> Maybe [(String, Type)]
153−typeHeadsAreEqual _ _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = Just []
147+typeHeadsAreEqual _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = Just []
154−typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]
148+typeHeadsAreEqual _ t (TypeVar v) = Just [(v, t)]
155−typeHeadsAreEqual _ _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []
149+typeHeadsAreEqual _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []
156−typeHeadsAreEqual m e (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m e h1 h2
150+typeHeadsAreEqual m (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m h1 h2
157− <*> typeHeadsAreEqual m e t1 t2
151+ <*> typeHeadsAreEqual m t1 t2
158−typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e name args of
159− Left _ -> Nothing
160− Right t1 -> typeHeadsAreEqual m e t1 t2
161−typeHeadsAreEqual _ _ REmpty REmpty = Just []
152+typeHeadsAreEqual _ REmpty REmpty = Just []
162−typeHeadsAreEqual m e r1@RCons{} r2@RCons{} =
153+typeHeadsAreEqual m r1@RCons{} r2@RCons{} =
163 let (s1, r1') = rowToList r1
154 let (s1, r1') = rowToList r1
164 (s2, r2') = rowToList r2
155 (s2, r2') = rowToList r2
165
156
166 int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
157 int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
167 sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
158 sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
168 sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
159 sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
169− in (++) <$> foldMap (uncurry (typeHeadsAreEqual m e)) int
160+ in (++) <$> foldMap (uncurry (typeHeadsAreEqual m)) int
170 <*> go sd1 r1' sd2 r2'
161 <*> go sd1 r1' sd2 r2'
171 where
162 where
172 go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Maybe [(String, Type)]
163 go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Maybe [(String, Type)]
@@ -176,7 +167,7 @@ typeHeadsAreEqual m e r1@RCons{} r2@RCons{} =
176 go [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = Just []
167 go [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = Just []
177 go sd r [] (TypeVar v) = Just [(v, rowFromList (sd, r))]
168 go sd r [] (TypeVar v) = Just [(v, rowFromList (sd, r))]
178 go _ _ _ _ = Nothing
169 go _ _ _ _ = Nothing
179−typeHeadsAreEqual _ _ _ _ = Nothing
170+typeHeadsAreEqual _ _ _ = Nothing
180
171
181-- |
172-- |
182-- Check all values in a list pairwise match a predicate
173-- Check all values in a list pairwise match a predicate
src/Language/PureScript/TypeChecker/Rows.hs−1
@@ -46,7 +46,6 @@ checkDuplicateLabels =
46 where
46 where
47 checkDups :: Type -> Check ()
47 checkDups :: Type -> Check ()
48 checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2
48 checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2
49− checkDups (SaturatedTypeSynonym _ ts) = mapM_ checkDups ts
50 checkDups (ForAll _ t _) = checkDups t
49 checkDups (ForAll _ t _) = checkDups t
51 checkDups (ConstrainedType args t) = do
50 checkDups (ConstrainedType args t) = do
52 mapM_ checkDups $ concatMap snd args
51 mapM_ checkDups $ concatMap snd args
src/Language/PureScript/TypeChecker/Subsumption.hs−8
@@ -20,7 +20,6 @@ module Language.PureScript.TypeChecker.Subsumption (
20import Data.List (sortBy)
20import Data.List (sortBy)
21import Data.Ord (comparing)
21import Data.Ord (comparing)
22
22
23−import Control.Monad
24import Control.Monad.Error.Class (MonadError(..))
23import Control.Monad.Error.Class (MonadError(..))
25import Control.Monad.Unify
24import Control.Monad.Unify
26
25
@@ -29,7 +28,6 @@ import Language.PureScript.Environment
29import Language.PureScript.Errors
28import Language.PureScript.Errors
30import Language.PureScript.TypeChecker.Monad
29import Language.PureScript.TypeChecker.Monad
31import Language.PureScript.TypeChecker.Skolems
30import Language.PureScript.TypeChecker.Skolems
32−import Language.PureScript.TypeChecker.Synonyms
33import Language.PureScript.TypeChecker.Unify
31import Language.PureScript.TypeChecker.Unify
34import Language.PureScript.Types
32import Language.PureScript.Types
35
33
@@ -57,12 +55,6 @@ subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2)
57 _ <- subsumes Nothing arg2 arg1
55 _ <- subsumes Nothing arg2 arg1
58 _ <- subsumes Nothing ret1 ret2
56 _ <- subsumes Nothing ret1 ret2
59 return val
57 return val
60−subsumes' val (SaturatedTypeSynonym name tyArgs) ty2 = do
61− ty1 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs
62− subsumes val ty1 ty2
63−subsumes' val ty1 (SaturatedTypeSynonym name tyArgs) = do
64− ty2 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs
65− subsumes val ty1 ty2
66subsumes' val (KindedType ty1 _) ty2 =
58subsumes' val (KindedType ty1 _) ty2 =
67 subsumes val ty1 ty2
59 subsumes val ty1 ty2
68subsumes' val ty1 (KindedType ty2 _) =
60subsumes' val ty1 (KindedType ty2 _) =
src/Language/PureScript/TypeChecker/Synonyms.hs+20−66
@@ -9,22 +9,18 @@
9-- Portability :
9-- Portability :
10--
10--
11-- |
11-- |
12−-- Functions for replacing fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor
12+-- Functions for replacing fully applied type synonyms
13--
13--
14-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
15
15
16{-# LANGUAGE FlexibleContexts #-}
16{-# LANGUAGE FlexibleContexts #-}
17{-# LANGUAGE MultiParamTypeClasses #-}
17{-# LANGUAGE MultiParamTypeClasses #-}
18+{-# LANGUAGE PatternGuards #-}
18{-# LANGUAGE GADTs #-}
19{-# LANGUAGE GADTs #-}
19{-# LANGUAGE CPP #-}
20{-# LANGUAGE CPP #-}
20
21
21module Language.PureScript.TypeChecker.Synonyms (
22module Language.PureScript.TypeChecker.Synonyms (
22− saturateAllTypeSynonyms,
23− desaturateAllTypeSynonyms,
24− replaceAllTypeSynonyms,
23+ replaceAllTypeSynonyms
25− expandAllTypeSynonyms,
26− expandTypeSynonym,
27− expandTypeSynonym'
28) where
24) where
29
25
30import Data.Maybe (fromMaybe)
26import Data.Maybe (fromMaybe)
@@ -38,73 +34,31 @@ import Control.Monad.State
38
34
39import Language.PureScript.Environment
35import Language.PureScript.Environment
40import Language.PureScript.Errors
36import Language.PureScript.Errors
41−import Language.PureScript.Names
42import Language.PureScript.TypeChecker.Monad
37import Language.PureScript.TypeChecker.Monad
43import Language.PureScript.Types
38import Language.PureScript.Types
44
39
45-- |
40-- |
46−-- Build a type substitution for a type synonym
41+-- Replace fully applied type synonyms.
47--
42--
48−buildTypeSubstitution :: M.Map (Qualified ProperName) Int -> Type -> Either ErrorMessage (Maybe Type)
43+replaceAllTypeSynonyms' :: Environment -> Type -> Either MultipleErrors Type
49−buildTypeSubstitution m = go 0 []
44+replaceAllTypeSynonyms' env = everywhereOnTypesTopDownM try
50 where
45 where
51− go :: Int -> [Type] -> Type -> Either ErrorMessage (Maybe Type)
46+ try :: Type -> Either MultipleErrors Type
52− go c args (TypeConstructor ctor) | M.lookup ctor m == Just c = return (Just $ SaturatedTypeSynonym ctor args)
47+ try t = fromMaybe t <$> go 0 [] t
53− go c _ (TypeConstructor ctor) | M.lookup ctor m > Just c = throwError $ ErrorMessage [] $ PartiallyAppliedSynonym ctor
54− go c args (TypeApp f arg) = go (c + 1) (arg:args) f
55− go _ _ _ = return Nothing
56−
57−-- |
58−-- Replace all type synonyms with the @SaturatedTypeSynonym@ data constructor
59−--
60−saturateAllTypeSynonyms :: M.Map (Qualified ProperName) Int -> Type -> Either ErrorMessage Type
61−saturateAllTypeSynonyms syns = everywhereOnTypesTopDownM replace
62− where
63− replace t = fromMaybe t <$> buildTypeSubstitution syns t
64
48
65−-- |
49+ go :: Int -> [Type] -> Type -> Either MultipleErrors (Maybe Type)
66−-- \"Desaturate\" @SaturatedTypeSynonym@s
50+ go c args (TypeConstructor ctor)
67−--
51+ | Just (synArgs, body) <- M.lookup ctor (typeSynonyms env)
68−desaturateAllTypeSynonyms :: Type -> Type
52+ , c == length synArgs
69−desaturateAllTypeSynonyms = everywhereOnTypes replaceSaturatedTypeSynonym
53+ = let repl = replaceAllTypeVars (zip (map fst synArgs) args) body
70− where
54+ in Just <$> try repl
71− replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args
72− replaceSaturatedTypeSynonym t = t
73−
74−-- |
75−-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate
76−-- better error messages during unification.
77−--
78−replaceAllTypeSynonyms' :: Environment -> Type -> Either ErrorMessage Type
79−replaceAllTypeSynonyms' env d =
80− let
81− syns = length . fst <$> typeSynonyms env
55+ | Just (synArgs, _) <- M.lookup ctor (typeSynonyms env)
82− in
56+ , length synArgs > c
83− saturateAllTypeSynonyms syns d
57+ = throwError . errorMessage $ PartiallyAppliedSynonym ctor
58+ go c args (TypeApp f arg) = go (c + 1) (arg : args) f
59+ go _ _ _ = return Nothing
84
60
85replaceAllTypeSynonyms :: (e ~ MultipleErrors, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
61replaceAllTypeSynonyms :: (e ~ MultipleErrors, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
86replaceAllTypeSynonyms d = do
62replaceAllTypeSynonyms d = do
87 env <- getEnv
63 env <- getEnv
88− either (throwError . singleError) return $ replaceAllTypeSynonyms' env d
64+ either throwError return $ replaceAllTypeSynonyms' env d
89−
90−-- |
91−-- Replace a type synonym and its arguments with the aliased type
92−--
93−expandTypeSynonym' :: Environment -> Qualified ProperName -> [Type] -> Either ErrorMessage Type
94−expandTypeSynonym' env name args =
95− case M.lookup name (typeSynonyms env) of
96− Just (synArgs, body) -> do
97− let repl = replaceAllTypeVars (zip (map fst synArgs) args) body
98− replaceAllTypeSynonyms' env repl
99− Nothing -> error "Type synonym was not defined"
100−
101−expandTypeSynonym :: (e ~ MultipleErrors, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type
102−expandTypeSynonym name args = do
103− env <- getEnv
104− either (throwError . singleError) return $ expandTypeSynonym' env name args
105−
106−expandAllTypeSynonyms :: (e ~ MultipleErrors, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
107−expandAllTypeSynonyms = everywhereOnTypesTopDownM go
108− where
109− go (SaturatedTypeSynonym name args) = expandTypeSynonym name args
110− go other = return other
src/Language/PureScript/TypeChecker/Types.hs+6−29
@@ -67,24 +67,17 @@ import Language.PureScript.TypeChecker.Synonyms
67import Language.PureScript.TypeChecker.Unify
67import Language.PureScript.TypeChecker.Unify
68import Language.PureScript.TypeClassDictionaries
68import Language.PureScript.TypeClassDictionaries
69import Language.PureScript.Types
69import Language.PureScript.Types
70−import qualified Language.PureScript.Constants as C
71
70
72-- |
71-- |
73-- Infer the types of multiple mutually-recursive values, and return elaborated values including
72-- Infer the types of multiple mutually-recursive values, and return elaborated values including
74-- type class dictionaries and type annotations.
73-- type class dictionaries and type annotations.
75--
74--
76−typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Expr)] -> Check [(Ident, (Expr, Type))]
75+typesOf :: ModuleName -> [(Ident, Expr)] -> Check [(Ident, (Expr, Type))]
77−typesOf mainModuleName moduleName vals = do
76+typesOf moduleName vals = do
78 tys <- fmap tidyUp . liftUnifyWarnings replace $ do
77 tys <- fmap tidyUp . liftUnifyWarnings replace $ do
79 (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals
78 (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals
80− ds1 <- parU typed $ \e -> do
81− triple@(_, (_, ty)) <- checkTypedBindingGroupElement moduleName e dict
79+ ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict
82− checkMain (fst e) ty
83− return triple
84− ds2 <- forM untyped $ \e -> do
85− triple@(_, (_, ty)) <- typeForBindingGroupElement e dict untypedDict
80+ ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict
86− checkMain (fst e) ty
87− return triple
88 return $ ds1 ++ ds2
81 return $ ds1 ++ ds2
89
82
90 forM tys $ \(ident, (val, ty)) -> do
83 forM tys $ \(ident, (val, ty)) -> do
@@ -94,21 +87,13 @@ typesOf mainModuleName moduleName vals = do
94 skolemEscapeCheck val'
87 skolemEscapeCheck val'
95 -- Check rows do not contain duplicate labels
88 -- Check rows do not contain duplicate labels
96 checkDuplicateLabels val'
89 checkDuplicateLabels val'
97− -- Remove type synonyms placeholders, and replace
98− -- top-level unification variables with named type variables.
99− let val'' = overTypes desaturateAllTypeSynonyms val'
100− ty' = varIfUnknown . desaturateAllTypeSynonyms $ ty
101− return (ident, (val'', ty'))
90+ return (ident, (val', varIfUnknown ty))
102 where
91 where
103 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
92 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
104 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts
93 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts
105 -- Replace all the wildcards types with their inferred types
94 -- Replace all the wildcards types with their inferred types
106 replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints $ WildcardInferredType (sub $? ty)
95 replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints $ WildcardInferredType (sub $? ty)
107 replace _ em = em
96 replace _ em = em
108− -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a
109− checkMain nm ty = when (Just moduleName == mainModuleName && nm == Ident C.main) $ do
110− [eff, a] <- replicateM 2 fresh
111− ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a
112
97
113type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)
98type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)
114
99
@@ -182,9 +167,7 @@ replaceTypeClassDictionaries mn =
182 let (_, f, _) = everywhereOnValuesTopDownM return go return
167 let (_, f, _) = everywhereOnValuesTopDownM return go return
183 in f
168 in f
184 where
169 where
185− go (TypeClassDictionary constraint dicts) = do
170+ go (TypeClassDictionary constraint dicts) = entails mn dicts constraint
186− env <- getEnv
187− entails env mn dicts constraint
188 go other = return other
171 go other = return other
189
172
190-- |
173-- |
@@ -473,9 +456,6 @@ check' val t@(ConstrainedType constraints ty) = do
473
456
474 instantiateSuperclass :: [String] -> [Type] -> [Type] -> [Type]
457 instantiateSuperclass :: [String] -> [Type] -> [Type] -> [Type]
475 instantiateSuperclass args supArgs tys = map (replaceAllTypeVars (zip args tys)) supArgs
458 instantiateSuperclass args supArgs tys = map (replaceAllTypeVars (zip args tys)) supArgs
476−check' val (SaturatedTypeSynonym name args) = do
477− ty <- introduceSkolemScope <=< expandTypeSynonym name $ args
478− check val ty
479check' val u@(TUnknown _) = do
459check' val u@(TUnknown _) = do
480 val'@(TypedValue _ _ ty) <- infer val
460 val'@(TypedValue _ _ ty) <- infer val
481 -- Don't unify an unknown with an inferred polytype
461 -- Don't unify an unknown with an inferred polytype
@@ -654,9 +634,6 @@ checkFunctionApplication' fn u@(TUnknown _) arg ret = do
654 ret' <- maybe fresh return ret
634 ret' <- maybe fresh return ret
655 u =?= function ty ret'
635 u =?= function ty ret'
656 return (ret', App fn arg')
636 return (ret', App fn arg')
657−checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg ret = do
658− ty <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs
659− checkFunctionApplication fn ty arg ret
660checkFunctionApplication' fn (KindedType ty _) arg ret =
637checkFunctionApplication' fn (KindedType ty _) arg ret =
661 checkFunctionApplication fn ty arg ret
638 checkFunctionApplication fn ty arg ret
662checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do
639checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do
src/Language/PureScript/TypeChecker/Unify.hs+10−25
@@ -36,11 +36,9 @@ import Control.Monad.Unify
36import Control.Monad.Writer
36import Control.Monad.Writer
37import Control.Monad.Error.Class (MonadError(..))
37import Control.Monad.Error.Class (MonadError(..))
38
38
39−import Language.PureScript.Environment
40import Language.PureScript.Errors
39import Language.PureScript.Errors
41import Language.PureScript.TypeChecker.Monad
40import Language.PureScript.TypeChecker.Monad
42import Language.PureScript.TypeChecker.Skolems
41import Language.PureScript.TypeChecker.Skolems
43−import Language.PureScript.TypeChecker.Synonyms
44import Language.PureScript.Types
42import Language.PureScript.Types
45
43
46instance Partial Type where
44instance Partial Type where
@@ -69,10 +67,6 @@ unifyTypes t1 t2 = rethrow (addHint (ErrorUnifyingTypes t1 t2)) $
69 unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()
67 unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()
70 unifyTypes' (TUnknown u) t = u =:= t
68 unifyTypes' (TUnknown u) t = u =:= t
71 unifyTypes' t (TUnknown u) = u =:= t
69 unifyTypes' t (TUnknown u) = u =:= t
72− unifyTypes' (SaturatedTypeSynonym name args) ty = do
73− ty1 <- introduceSkolemScope <=< expandTypeSynonym name $ args
74− ty1 `unifyTypes` ty
75− unifyTypes' ty s@(SaturatedTypeSynonym _ _) = s `unifyTypes` ty
76 unifyTypes' (ForAll ident1 ty1 sc1) (ForAll ident2 ty2 sc2) =
70 unifyTypes' (ForAll ident1 ty1 sc1) (ForAll ident2 ty2 sc2) =
77 case (sc1, sc2) of
71 case (sc1, sc2) of
78 (Just sc1', Just sc2') -> do
72 (Just sc1', Just sc2') -> do
@@ -132,10 +126,6 @@ unifyRows r1 r2 =
132 rest <- fresh
126 rest <- fresh
133 u1 =:= rowFromList (sd2, rest)
127 u1 =:= rowFromList (sd2, rest)
134 u2 =:= rowFromList (sd1, rest)
128 u2 =:= rowFromList (sd1, rest)
135− unifyRows' sd1 (SaturatedTypeSynonym name args) sd2 r2' = do
136− r1' <- expandTypeSynonym name args
137− unifyRows (rowFromList (sd1, r1')) (rowFromList (sd2, r2'))
138− unifyRows' sd1 r1' sd2 r2'@(SaturatedTypeSynonym _ _) = unifyRows' sd2 r2' sd1 r1'
139 unifyRows' [] REmpty [] REmpty = return ()
129 unifyRows' [] REmpty [] REmpty = return ()
140 unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()
130 unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()
141 unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return ()
131 unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return ()
@@ -144,26 +134,21 @@ unifyRows r1 r2 =
144-- |
134-- |
145-- Check that two types unify
135-- Check that two types unify
146--
136--
147−unifiesWith :: Environment -> Type -> Type -> Bool
137+unifiesWith :: Type -> Type -> Bool
148−unifiesWith _ (TUnknown u1) (TUnknown u2) | u1 == u2 = True
138+unifiesWith (TUnknown u1) (TUnknown u2) | u1 == u2 = True
149−unifiesWith _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = True
139+unifiesWith (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = True
150−unifiesWith _ (TypeVar v1) (TypeVar v2) | v1 == v2 = True
140+unifiesWith (TypeVar v1) (TypeVar v2) | v1 == v2 = True
151−unifiesWith _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True
141+unifiesWith (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True
152−unifiesWith e (TypeApp h1 t1) (TypeApp h2 t2) = unifiesWith e h1 h2 && unifiesWith e t1 t2
142+unifiesWith (TypeApp h1 t1) (TypeApp h2 t2) = h1 `unifiesWith` h2 && t1 `unifiesWith` t2
153−unifiesWith e (SaturatedTypeSynonym name args) t2 =
154− case expandTypeSynonym' e name args of
155− Left _ -> False
156− Right t1 -> unifiesWith e t1 t2
157−unifiesWith e t1 t2@(SaturatedTypeSynonym _ _) = unifiesWith e t2 t1
158−unifiesWith _ REmpty REmpty = True
143+unifiesWith REmpty REmpty = True
159−unifiesWith e r1@RCons{} r2@RCons{} =
144+unifiesWith r1@RCons{} r2@RCons{} =
160 let (s1, r1') = rowToList r1
145 let (s1, r1') = rowToList r1
161 (s2, r2') = rowToList r2
146 (s2, r2') = rowToList r2
162
147
163 int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
148 int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
164 sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
149 sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
165 sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
150 sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
166− in all (uncurry (unifiesWith e)) int && go sd1 r1' sd2 r2'
151+ in all (uncurry unifiesWith) int && go sd1 r1' sd2 r2'
167 where
152 where
168 go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Bool
153 go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Bool
169 go [] REmpty [] REmpty = True
154 go [] REmpty [] REmpty = True
@@ -173,7 +158,7 @@ unifiesWith e r1@RCons{} r2@RCons{} =
173 go _ _ [] (TUnknown _) = True
158 go _ _ [] (TUnknown _) = True
174 go _ (TUnknown _) _ (TUnknown _) = True
159 go _ (TUnknown _) _ (TUnknown _) = True
175 go _ _ _ _ = False
160 go _ _ _ _ = False
176−unifiesWith _ _ _ = False
161+unifiesWith _ _ = False
177
162
178-- |
163-- |
179-- Replace a single type variable with a new unification variable
164-- Replace a single type variable with a new unification variable
src/Language/PureScript/Types.hs−12
@@ -67,10 +67,6 @@ data Type
67 --
67 --
68 | TypeApp Type Type
68 | TypeApp Type Type
69 -- |
69 -- |
70− -- A type synonym which is \"saturated\", i.e. fully applied
71− --
72− | SaturatedTypeSynonym (Qualified ProperName) [Type]
73− -- |
74 -- Forall quantifier
70 -- Forall quantifier
75 --
71 --
76 | ForAll String Type (Maybe SkolemScope)
72 | ForAll String Type (Maybe SkolemScope)
@@ -159,7 +155,6 @@ replaceAllTypeVars = go []
159 go :: [String] -> [(String, Type)] -> Type -> Type
155 go :: [String] -> [(String, Type)] -> Type -> Type
160 go _ m (TypeVar v) = fromMaybe (TypeVar v) (v `lookup` m)
156 go _ m (TypeVar v) = fromMaybe (TypeVar v) (v `lookup` m)
161 go bs m (TypeApp t1 t2) = TypeApp (go bs m t1) (go bs m t2)
157 go bs m (TypeApp t1 t2) = TypeApp (go bs m t1) (go bs m t2)
162− go bs m (SaturatedTypeSynonym name' ts) = SaturatedTypeSynonym name' $ map (go bs m) ts
163 go bs m f@(ForAll v t sco) | v `elem` keys = go bs (filter ((/= v) . fst) m) f
158 go bs m f@(ForAll v t sco) | v `elem` keys = go bs (filter ((/= v) . fst) m) f
164 | v `elem` usedVars =
159 | v `elem` usedVars =
165 let v' = genName v (keys ++ bs ++ usedVars)
160 let v' = genName v (keys ++ bs ++ usedVars)
@@ -198,7 +193,6 @@ freeTypeVariables = nub . go []
198 go :: [String] -> Type -> [String]
193 go :: [String] -> Type -> [String]
199 go bound (TypeVar v) | v `notElem` bound = [v]
194 go bound (TypeVar v) | v `notElem` bound = [v]
200 go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2
195 go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2
201− go bound (SaturatedTypeSynonym _ ts) = concatMap (go bound) ts
202 go bound (ForAll v t _) = go (v : bound) t
196 go bound (ForAll v t _) = go (v : bound) t
203 go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) . snd) cs ++ go bound t
197 go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) . snd) cs ++ go bound t
204 go bound (RCons _ t r) = go bound t ++ go bound r
198 go bound (RCons _ t r) = go bound t ++ go bound r
@@ -245,7 +239,6 @@ everywhereOnTypes :: (Type -> Type) -> Type -> Type
245everywhereOnTypes f = go
239everywhereOnTypes f = go
246 where
240 where
247 go (TypeApp t1 t2) = f (TypeApp (go t1) (go t2))
241 go (TypeApp t1 t2) = f (TypeApp (go t1) (go t2))
248− go (SaturatedTypeSynonym name tys) = f (SaturatedTypeSynonym name (map go tys))
249 go (ForAll arg ty sco) = f (ForAll arg (go ty) sco)
242 go (ForAll arg ty sco) = f (ForAll arg (go ty) sco)
250 go (ConstrainedType cs ty) = f (ConstrainedType (map (fmap (map go)) cs) (go ty))
243 go (ConstrainedType cs ty) = f (ConstrainedType (map (fmap (map go)) cs) (go ty))
251 go (RCons name ty rest) = f (RCons name (go ty) (go rest))
244 go (RCons name ty rest) = f (RCons name (go ty) (go rest))
@@ -259,7 +252,6 @@ everywhereOnTypesTopDown :: (Type -> Type) -> Type -> Type
259everywhereOnTypesTopDown f = go . f
252everywhereOnTypesTopDown f = go . f
260 where
253 where
261 go (TypeApp t1 t2) = TypeApp (go (f t1)) (go (f t2))
254 go (TypeApp t1 t2) = TypeApp (go (f t1)) (go (f t2))
262− go (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym name (map (go . f) tys)
263 go (ForAll arg ty sco) = ForAll arg (go (f ty)) sco
255 go (ForAll arg ty sco) = ForAll arg (go (f ty)) sco
264 go (ConstrainedType cs ty) = ConstrainedType (map (fmap (map (go . f))) cs) (go (f ty))
256 go (ConstrainedType cs ty) = ConstrainedType (map (fmap (map (go . f))) cs) (go (f ty))
265 go (RCons name ty rest) = RCons name (go (f ty)) (go (f rest))
257 go (RCons name ty rest) = RCons name (go (f ty)) (go (f rest))
@@ -273,7 +265,6 @@ everywhereOnTypesM :: (Functor m, Applicative m, Monad m) => (Type -> m Type) ->
273everywhereOnTypesM f = go
265everywhereOnTypesM f = go
274 where
266 where
275 go (TypeApp t1 t2) = (TypeApp <$> go t1 <*> go t2) >>= f
267 go (TypeApp t1 t2) = (TypeApp <$> go t1 <*> go t2) >>= f
276− go (SaturatedTypeSynonym name tys) = (SaturatedTypeSynonym name <$> mapM go tys) >>= f
277 go (ForAll arg ty sco) = (ForAll arg <$> go ty <*> pure sco) >>= f
268 go (ForAll arg ty sco) = (ForAll arg <$> go ty <*> pure sco) >>= f
278 go (ConstrainedType cs ty) = (ConstrainedType <$> mapM (sndM (mapM go)) cs <*> go ty) >>= f
269 go (ConstrainedType cs ty) = (ConstrainedType <$> mapM (sndM (mapM go)) cs <*> go ty) >>= f
279 go (RCons name ty rest) = (RCons name <$> go ty <*> go rest) >>= f
270 go (RCons name ty rest) = (RCons name <$> go ty <*> go rest) >>= f
@@ -287,7 +278,6 @@ everywhereOnTypesTopDownM :: (Functor m, Applicative m, Monad m) => (Type -> m T
287everywhereOnTypesTopDownM f = go <=< f
278everywhereOnTypesTopDownM f = go <=< f
288 where
279 where
289 go (TypeApp t1 t2) = TypeApp <$> (f t1 >>= go) <*> (f t2 >>= go)
280 go (TypeApp t1 t2) = TypeApp <$> (f t1 >>= go) <*> (f t2 >>= go)
290− go (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym name <$> mapM (go <=< f) tys
291 go (ForAll arg ty sco) = ForAll arg <$> (f ty >>= go) <*> pure sco
281 go (ForAll arg ty sco) = ForAll arg <$> (f ty >>= go) <*> pure sco
292 go (ConstrainedType cs ty) = ConstrainedType <$> mapM (sndM (mapM (go <=< f))) cs <*> (f ty >>= go)
282 go (ConstrainedType cs ty) = ConstrainedType <$> mapM (sndM (mapM (go <=< f))) cs <*> (f ty >>= go)
293 go (RCons name ty rest) = RCons name <$> (f ty >>= go) <*> (f rest >>= go)
283 go (RCons name ty rest) = RCons name <$> (f ty >>= go) <*> (f rest >>= go)
@@ -301,7 +291,6 @@ everythingOnTypes :: (r -> r -> r) -> (Type -> r) -> Type -> r
301everythingOnTypes (<>) f = go
291everythingOnTypes (<>) f = go
302 where
292 where
303 go t@(TypeApp t1 t2) = f t <> go t1 <> go t2
293 go t@(TypeApp t1 t2) = f t <> go t1 <> go t2
304− go t@(SaturatedTypeSynonym _ tys) = foldl (<>) (f t) (map go tys)
305 go t@(ForAll _ ty _) = f t <> go ty
294 go t@(ForAll _ ty _) = f t <> go ty
306 go t@(ConstrainedType cs ty) = foldl (<>) (f t) (map go $ concatMap snd cs) <> go ty
295 go t@(ConstrainedType cs ty) = foldl (<>) (f t) (map go $ concatMap snd cs) <> go ty
307 go t@(RCons _ ty rest) = f t <> go ty <> go rest
296 go t@(RCons _ ty rest) = f t <> go ty <> go rest
@@ -316,7 +305,6 @@ everythingWithContextOnTypes s0 r0 (<>) f = go' s0
316 where
305 where
317 go' s t = let (s', r) = f s t in r <> go s' t
306 go' s t = let (s', r) = f s t in r <> go s' t
318 go s (TypeApp t1 t2) = go' s t1 <> go' s t2
307 go s (TypeApp t1 t2) = go' s t1 <> go' s t2
319− go s (SaturatedTypeSynonym _ tys) = foldl (<>) r0 (map (go' s) tys)
320 go s (ForAll _ ty _) = go' s ty
308 go s (ForAll _ ty _) = go' s ty
321 go s (ConstrainedType cs ty) = foldl (<>) r0 (map (go' s) $ concatMap snd cs) <> go' s ty
309 go s (ConstrainedType cs ty) = foldl (<>) r0 (map (go' s) $ concatMap snd cs) <> go' s ty
322 go s (RCons _ ty rest) = go' s ty <> go' s rest
310 go s (RCons _ ty rest) = go' s ty <> go' s rest