git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge pull request #1501 from purescript/tempbuild

Combined feature branch

commit7e6162f520f2e6fb3d68ddb2fdc7fb6bd112baed authorPhil Freeman <paf31@cantab.net> dateTue 13 Oct 2015, 20:08 (11 years ago) parent8758966679c93c
18 files changed+372−317
compare with golang
unifiedsplit
LICENSE+167−68 license-generator/generate+3 psci/PSCi.hs+4−4 purescript.cabal+4−1 src/Language/PureScript/AST/Traversals.hs+3−3 src/Language/PureScript/Docs/Convert.hs−1 src/Language/PureScript/Errors.hs+4 src/Language/PureScript/Make.hs+119−59 src/Language/PureScript/ModuleDependencies.hs+9−7 src/Language/PureScript/Sugar/Names.hs−1 src/Language/PureScript/TypeChecker.hs+8−8 src/Language/PureScript/TypeChecker/Entailment.hs+15−24 src/Language/PureScript/TypeChecker/Rows.hs−1 src/Language/PureScript/TypeChecker/Subsumption.hs−8 src/Language/PureScript/TypeChecker/Synonyms.hs+20−66 src/Language/PureScript/TypeChecker/Types.hs+6−29 src/Language/PureScript/TypeChecker/Unify.hs+10−25 src/Language/PureScript/Types.hs−12
LICENSE+167−68
@@ -31,6 +31,7 @@ PureScript uses the following Haskell library packages. Their license files foll
3131 array
3232 attoparsec
3333 base
34+ binary
3435 blaze-builder
3536 bower-json
3637 boxes
@@ -45,9 +46,10 @@ PureScript uses the following Haskell library packages. Their license files foll
4546 haskeline
4647 integer-gmp
4748 language-javascript
49+ lifted-base
50+ monad-control
4851 mtl
4952 nats
50− old-locale
5153 optparse-applicative
5254 parsec
5355 pattern-arrows
@@ -59,12 +61,14 @@ PureScript uses the following Haskell library packages. Their license files foll
5961 scientific
6062 semigroups
6163 split
64+ stm
6265 syb
6366 template-haskell
6467 terminfo
6568 text
6669 time
6770 transformers
71+ transformers-base
6872 transformers-compat
6973 unix
7074 unordered-containers
@@ -449,6 +453,39 @@ base LICENSE file:
449453
450454 -----------------------------------------------------------------------------
451455
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+
452489blaze-builder LICENSE file:
453490
454491 Copyright Jasper Van der Jeugt 2010, Simon Meier 2010 & 2011
@@ -967,6 +1004,70 @@ language-javascript LICENSE file:
9671004 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
9681005 OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
9691006
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+
9701071mtl LICENSE file:
9711072
9721073 The Glasgow Haskell Compiler License
@@ -1034,72 +1135,6 @@ nats LICENSE file:
10341135 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
10351136 POSSIBILITY OF SUCH DAMAGE.
10361137
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−
11031138optparse-applicative LICENSE file:
11041139
11051140 Copyright (c) 2012, Paolo Capriotti
@@ -1450,6 +1485,40 @@ split LICENSE file:
14501485 OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
14511486 SUCH DAMAGE.
14521487
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+
14531522syb LICENSE file:
14541523
14551524 This library (libraries/syb) is derived from code from several
@@ -1674,6 +1743,36 @@ transformers LICENSE file:
16741743 OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
16751744 DAMAGE.
16761745
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+
16771776transformers-compat LICENSE file:
16781777
16791778 Copyright 2012 Edward Kmett
@@ -1836,7 +1935,7 @@ vector LICENSE file:
18361935
18371936void LICENSE file:
18381937
1839− Copyright 2013 Edward Kmett
1938+ Copyright 2015 Edward Kmett
18401939
18411940 All rights reserved.
18421941
license-generator/generate+3
@@ -9,6 +9,9 @@ set -e # exit on error
99set -u # exit on undefined variable
1010set -o pipefail # propagate nonzero exit codes through pipelines
1111
12+export LC_CTYPE=C
13+export LANG=C
14+
1215if ! which cabal-dependency-licenses >/dev/null; then
1316 echo "$0: the program 'cabal-dependency-licenses' is required." >&2
1417 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
263263
264264make :: PSCiState -> [(Either P.RebuildPolicy FilePath, P.Module)] -> P.Make P.Environment
265265make PSCiState{..} ms = P.make actions' (map snd (psciLoadedModules ++ ms))
266− where
267− filePathMap = M.fromList $ (first P.getModuleName . swap) `map` (psciLoadedModules ++ ms)
268− actions = P.buildMakeActions modulesDir filePathMap psciForeignFiles False
269− actions' = actions { P.progress = const (return ()) }
266+ where
267+ filePathMap = M.fromList $ (first P.getModuleName . swap) `map` (psciLoadedModules ++ ms)
268+ actions = P.buildMakeActions modulesDir filePathMap psciForeignFiles False
269+ actions' = actions { P.progress = const (return ()) }
270270
271271-- |
272272-- Takes a value declaration and evaluates it with the current state.
purescript.cabal+4−1
@@ -32,6 +32,9 @@ source-repository head
3232
3333library
3434 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,
3538 containers -any,
3639 unordered-containers -any,
3740 dlist -any,
@@ -176,7 +179,7 @@ executable psc
176179 main-is: Main.hs
177180 buildable: True
178181 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"
180183
181184executable psci
182185 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')
216216 f' d = f d
217217
218218 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
220220 g' v@(Parens v1) = g v <> 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
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
223223 g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)
224224 g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)
225225 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
166166 unQual x = let (P.Qualified _ y) = x in P.runProperName y
167167
168168 extractProperNames (P.TypeConstructor n) = [unQual n]
169− extractProperNames (P.SaturatedTypeSynonym n _) = [unQual n]
170169 extractProperNames _ = []
171170
172171 childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)
src/Language/PureScript/Errors.hs+4
@@ -98,6 +98,7 @@ data SimpleErrorMessage
9898 | CtorConflictsWithClass ProperName
9999 | ClassConflictsWithType ProperName
100100 | ClassConflictsWithCtor ProperName
101+ | DuplicateModuleName ModuleName
101102 | DuplicateClassExport ProperName
102103 | DuplicateValueExport Ident
103104 | DuplicateTypeArgument String
@@ -237,6 +238,7 @@ errorCode em = case unwrapErrorMessage em of
237238 CtorConflictsWithClass{} -> "CtorConflictsWithClass"
238239 ClassConflictsWithType{} -> "ClassConflictsWithType"
239240 ClassConflictsWithCtor{} -> "ClassConflictsWithCtor"
241+ DuplicateModuleName{} -> "DuplicateModuleName"
240242 DuplicateClassExport{} -> "DuplicateClassExport"
241243 DuplicateValueExport{} -> "DuplicateValueExport"
242244 DuplicateTypeArgument{} -> "DuplicateTypeArgument"
@@ -505,6 +507,8 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir
505507 line $ "Type class " ++ runProperName nm ++ " conflicts with type declaration of the same name"
506508 renderSimpleErrorMessage (ClassConflictsWithCtor nm) =
507509 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."
508512 renderSimpleErrorMessage (DuplicateClassExport nm) =
509513 line $ "Duplicate export declaration for type class " ++ runProperName nm
510514 renderSimpleErrorMessage (DuplicateValueExport nm) =
src/Language/PureScript/Make.hs+119−59
@@ -19,6 +19,8 @@
1919{-# LANGUAGE RankNTypes #-}
2020{-# LANGUAGE RecordWildCards #-}
2121{-# LANGUAGE ScopedTypeVariables #-}
22+{-# LANGUAGE MultiParamTypeClasses #-}
23+{-# LANGUAGE TypeFamilies #-}
2224{-# LANGUAGE CPP #-}
2325
2426module Language.PureScript.Make
@@ -39,29 +41,31 @@ module Language.PureScript.Make
3941#if __GLASGOW_HASKELL__ < 710
4042import Control.Applicative
4143#endif
42−import Control.Arrow ((&&&))
4344import Control.Monad
4445import Control.Monad.Error.Class (MonadError(..))
4546import Control.Monad.Trans.Except
4647import Control.Monad.Reader
4748import Control.Monad.Writer.Strict
4849import Control.Monad.Supply
50+import Control.Monad.Base (MonadBase(..))
51+import Control.Monad.Trans.Control (MonadBaseControl(..))
4952
50−import Data.Function (on)
51−import Data.Either (partitionEithers)
52−import Data.List (sortBy, groupBy, foldl')
53−import Data.Maybe (fromMaybe)
53+import Control.Concurrent.Lifted as C
54+
55+import Data.List (foldl', sort)
56+import Data.Maybe (fromMaybe, catMaybes)
5457import Data.Time.Clock
5558import Data.String (fromString)
5659import Data.Foldable (for_)
5760#if __GLASGOW_HASKELL__ < 710
5861import Data.Traversable (traverse)
5962#endif
63+import Data.Traversable (for)
6064import Data.Version (showVersion)
6165import Data.Aeson (encode, decode)
6266import qualified Data.ByteString.Lazy as B
63−import qualified Data.Map as M
6467import qualified Data.Set as S
68+import qualified Data.Map as M
6569
6670import System.Directory
6771 (doesFileExist, getModificationTime, createDirectoryIfMissing)
@@ -150,65 +154,113 @@ data RebuildPolicy
150154-- If timestamps have not changed, the externs file can be used to provide the module's types without
151155-- having to typecheck the module again.
152156--
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)
154158 => MakeActions m
155159 -> [Module]
156160 -> m Environment
157161make MakeActions{..} ms = do
158− (sorted, graph) <- sortModules $ map importPrim ms
159− toRebuild <- foldM (\s (Module _ _ moduleName' _ _) -> do
160− inputTimestamp <- getInputTimestamp moduleName'
161− outputTimestamp <- getOutputTimestamp moduleName'
162− return $ case (inputTimestamp, outputTimestamp) of
163− (Right (Just t1), Just t2) | t1 < t2 -> s
164− (Left RebuildNever, Just _) -> s
165− _ -> S.insert moduleName' s) S.empty sorted
166−
167− (externs, toBuild) <- partitionEithers <$> rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
168− for_ toBuild lint
169− (desugared, nextVar) <- runSupplyT 0 $ desugar externs toBuild
170− let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
171− evalSupplyT nextVar $ go env desugared
172− where
162+ checkModuleNamesAreUnique
163+
164+ (sorted, graph) <- sortModules ms
165+
166+ barriers <- zip (map getModuleName sorted) <$> replicateM (length ms) ((,) <$> C.newEmptyMVar <*> C.newEmptyMVar)
167+
168+ for_ sorted $ \m -> fork $ do
169+ let deps = fromMaybe (error "make: module not found in dependency graph.") (lookup (getModuleName m) graph)
170+ buildModule barriers (importPrim m) (deps `inOrderOf` map getModuleName sorted)
171+
172+ -- Wait for all threads to complete, and collect errors.
173+ errors <- catMaybes <$> for barriers (takeMVar . snd . snd)
174+
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)
180+ return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment (fromMaybe (error "make: externs were missing but no errors reported.") externs)
173181
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 ]
209182 where
210− combine :: (Ord a) => [(a, b)] -> M.Map a [b]
211− combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
183+ checkModuleNamesAreUnique :: m ()
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
212264
213265-- |
214266-- 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])
231283newtype Make a = Make { unMake :: ReaderT Options (WriterT MultipleErrors (ExceptT MultipleErrors IO)) a }
232284 deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
233285
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+
234294-- |
235295-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
236296--
src/Language/PureScript/ModuleDependencies.hs+9−7
@@ -23,20 +23,17 @@ import Control.Monad.Error.Class (MonadError(..))
2323
2424import Data.Graph
2525import Data.List (nub)
26−import Data.Maybe (mapMaybe)
26+import Data.Maybe (fromMaybe, mapMaybe)
2727
2828import Language.PureScript.AST
2929import Language.PureScript.Names
3030import Language.PureScript.Types
3131import Language.PureScript.Errors
3232
33−-- |
34−-- A list of modules with their dependencies
35−--
33+-- | A list of modules with their transitive dependencies
3634type ModuleGraph = [(ModuleName, [ModuleName])]
3735
38−-- |
39−-- Sort a collection of modules based on module dependencies.
36+-- | Sort a collection of modules based on module dependencies.
4037--
4138-- Reports an error if the module graph contains a cycle.
4239--
@@ -44,7 +41,12 @@ sortModules :: (MonadError MultipleErrors m) => [Module] -> m ([Module], ModuleG
4441sortModules ms = do
4542 let verts = map (\m@(Module _ _ _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms
4643 ms' <- mapM toModule $ stronglyConnComp verts
47− let moduleGraph = map (\(_, mn, deps) -> (mn, deps)) verts
44+ let (graph, fromVertex, toVertex) = graphFromEdges 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))
4850 return (ms', moduleGraph)
4951
5052-- |
src/Language/PureScript/Sugar/Names.hs−1
@@ -207,7 +207,6 @@ renameInModule env imports (Module ss coms mn decls exps) =
207207 where
208208 updateType :: Type -> m Type
209209 updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos
210− updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name pos <*> pure tys
211210 updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t
212211 updateType t = return t
213212
src/Language/PureScript/TypeChecker.hs+8−8
@@ -132,8 +132,8 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms
132132--
133133-- * Process module imports
134134--
135−typeCheckAll :: Maybe ModuleName -> ModuleName -> [DeclarationRef] -> [Declaration] -> Check [Declaration]
136−typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds
135+typeCheckAll :: ModuleName -> [DeclarationRef] -> [Declaration] -> Check [Declaration]
136+typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds
137137 where
138138 go :: Declaration -> Check Declaration
139139 go (DataDeclaration dtype name args dctors) = do
@@ -181,7 +181,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix
181181 go (ValueDeclaration name nameKind [] (Right val)) =
182182 warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do
183183 valueIsNotDefined moduleName name
184− [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
184+ [(_, (val', ty))] <- typesOf moduleName [(name, val)]
185185 addValue moduleName name ty nameKind
186186 return $ ValueDeclaration name nameKind [] $ Right val'
187187 go (ValueDeclaration{}) = error "Binders were not desugared"
@@ -189,7 +189,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix
189189 warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do
190190 forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
191191 valueIsNotDefined moduleName name
192− tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
192+ tys <- typesOf moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
193193 vals' <- forM [ (name, val, nameKind, ty)
194194 | (name, nameKind, _) <- vals
195195 , (name', (val, ty)) <- tys
@@ -267,11 +267,11 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix
267267-- Type check an entire module and ensure all types and classes defined within the module that are
268268-- required by exported members are also exported.
269269--
270−typeCheckModule :: Maybe ModuleName -> Module -> Check Module
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
270+typeCheckModule :: Module -> Check Module
271+typeCheckModule (Module _ _ _ _ Nothing) = error "exports should have been elaborated"
272+typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do
273273 modify (\s -> s { checkCurrentModule = Just mn })
274− decls' <- typeCheckAll mainModuleName mn exps decls
274+ decls' <- typeCheckAll mn exps decls
275275 forM_ exps $ \e -> do
276276 checkTypesAreExported e
277277 checkClassMembersAreExported e
src/Language/PureScript/TypeChecker/Entailment.hs+15−24
@@ -37,10 +37,8 @@ import Control.Monad.Writer.Class (tell)
3737
3838import Language.PureScript.AST
3939import Language.PureScript.Errors
40−import Language.PureScript.Environment
4140import Language.PureScript.Names
4241import Language.PureScript.TypeChecker.Monad
43−import Language.PureScript.TypeChecker.Synonyms
4442import Language.PureScript.TypeChecker.Unify
4543import Language.PureScript.TypeClassDictionaries
4644import Language.PureScript.Types
@@ -50,8 +48,8 @@ import qualified Language.PureScript.Constants as C
5048-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
5149-- return a type class dictionary reference.
5250--
53−entails :: Environment -> ModuleName -> M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) -> Constraint -> Check Expr
54−entails env moduleName context = solve
51+entails :: ModuleName -> M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) -> Constraint -> Check Expr
52+entails moduleName context = solve
5553 where
5654 forClassName :: Qualified ProperName -> [Type] -> [TypeClassDictionaryInScope]
5755 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
7472 go :: Int -> Qualified ProperName -> [Type] -> Check DictionaryValue
7573 go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'
7674 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'
8175 let instances = do
82− tcd <- forClassName className' tys''
76+ tcd <- forClassName className' tys'
8377 -- 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)
8579 return (subst, tcd)
8680 (subst, tcd) <- unique instances
8781 -- Solve any necessary subgoals
@@ -139,7 +133,7 @@ entails env moduleName context = solve
139133 verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]
140134 verifySubstitution subst = do
141135 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)
143137 return $ map head grps
144138
145139 valUndefined :: Expr
@@ -149,24 +143,21 @@ entails env moduleName context = solve
149143-- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup),
150144-- and return a substitution from type variables to types which makes the type heads unify.
151145--
152−typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]
153−typeHeadsAreEqual _ _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = Just []
154−typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]
155−typeHeadsAreEqual _ _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []
156−typeHeadsAreEqual m e (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m e h1 h2
157− <*> typeHeadsAreEqual m e 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 []
162−typeHeadsAreEqual m e r1@RCons{} r2@RCons{} =
146+typeHeadsAreEqual :: ModuleName -> Type -> Type -> Maybe [(String, Type)]
147+typeHeadsAreEqual _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = Just []
148+typeHeadsAreEqual _ t (TypeVar v) = Just [(v, t)]
149+typeHeadsAreEqual _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []
150+typeHeadsAreEqual m (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m h1 h2
151+ <*> typeHeadsAreEqual m t1 t2
152+typeHeadsAreEqual _ REmpty REmpty = Just []
153+typeHeadsAreEqual m r1@RCons{} r2@RCons{} =
163154 let (s1, r1') = rowToList r1
164155 (s2, r2') = rowToList r2
165156
166157 int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
167158 sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
168159 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
170161 <*> go sd1 r1' sd2 r2'
171162 where
172163 go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Maybe [(String, Type)]
@@ -176,7 +167,7 @@ typeHeadsAreEqual m e r1@RCons{} r2@RCons{} =
176167 go [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = Just []
177168 go sd r [] (TypeVar v) = Just [(v, rowFromList (sd, r))]
178169 go _ _ _ _ = Nothing
179−typeHeadsAreEqual _ _ _ _ = Nothing
170+typeHeadsAreEqual _ _ _ = Nothing
180171
181172-- |
182173-- Check all values in a list pairwise match a predicate
src/Language/PureScript/TypeChecker/Rows.hs−1
@@ -46,7 +46,6 @@ checkDuplicateLabels =
4646 where
4747 checkDups :: Type -> Check ()
4848 checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2
49− checkDups (SaturatedTypeSynonym _ ts) = mapM_ checkDups ts
5049 checkDups (ForAll _ t _) = checkDups t
5150 checkDups (ConstrainedType args t) = do
5251 mapM_ checkDups $ concatMap snd args
src/Language/PureScript/TypeChecker/Subsumption.hs−8
@@ -20,7 +20,6 @@ module Language.PureScript.TypeChecker.Subsumption (
2020import Data.List (sortBy)
2121import Data.Ord (comparing)
2222
23−import Control.Monad
2423import Control.Monad.Error.Class (MonadError(..))
2524import Control.Monad.Unify
2625
@@ -29,7 +28,6 @@ import Language.PureScript.Environment
2928import Language.PureScript.Errors
3029import Language.PureScript.TypeChecker.Monad
3130import Language.PureScript.TypeChecker.Skolems
32−import Language.PureScript.TypeChecker.Synonyms
3331import Language.PureScript.TypeChecker.Unify
3432import Language.PureScript.Types
3533
@@ -57,12 +55,6 @@ subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2)
5755 _ <- subsumes Nothing arg2 arg1
5856 _ <- subsumes Nothing ret1 ret2
5957 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
6658subsumes' val (KindedType ty1 _) ty2 =
6759 subsumes val ty1 ty2
6860subsumes' val ty1 (KindedType ty2 _) =
src/Language/PureScript/TypeChecker/Synonyms.hs+20−66
@@ -9,22 +9,18 @@
99-- Portability :
1010--
1111-- |
12−-- Functions for replacing fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor
12+-- Functions for replacing fully applied type synonyms
1313--
1414-----------------------------------------------------------------------------
1515
1616{-# LANGUAGE FlexibleContexts #-}
1717{-# LANGUAGE MultiParamTypeClasses #-}
18+{-# LANGUAGE PatternGuards #-}
1819{-# LANGUAGE GADTs #-}
1920{-# LANGUAGE CPP #-}
2021
2122module Language.PureScript.TypeChecker.Synonyms (
22− saturateAllTypeSynonyms,
23− desaturateAllTypeSynonyms,
24− replaceAllTypeSynonyms,
25− expandAllTypeSynonyms,
26− expandTypeSynonym,
27− expandTypeSynonym'
23+ replaceAllTypeSynonyms
2824) where
2925
3026import Data.Maybe (fromMaybe)
@@ -38,73 +34,31 @@ import Control.Monad.State
3834
3935import Language.PureScript.Environment
4036import Language.PureScript.Errors
41−import Language.PureScript.Names
4237import Language.PureScript.TypeChecker.Monad
4338import Language.PureScript.Types
4439
4540-- |
46−-- Build a type substitution for a type synonym
41+-- Replace fully applied type synonyms.
4742--
48−buildTypeSubstitution :: M.Map (Qualified ProperName) Int -> Type -> Either ErrorMessage (Maybe Type)
49−buildTypeSubstitution m = go 0 []
43+replaceAllTypeSynonyms' :: Environment -> Type -> Either MultipleErrors Type
44+replaceAllTypeSynonyms' env = everywhereOnTypesTopDownM try
5045 where
51− go :: Int -> [Type] -> Type -> Either ErrorMessage (Maybe Type)
52− go c args (TypeConstructor ctor) | M.lookup ctor m == Just c = return (Just $ SaturatedTypeSynonym ctor args)
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
46+ try :: Type -> Either MultipleErrors Type
47+ try t = fromMaybe t <$> go 0 [] t
6448
65−-- |
66−-- \"Desaturate\" @SaturatedTypeSynonym@s
67−--
68−desaturateAllTypeSynonyms :: Type -> Type
69−desaturateAllTypeSynonyms = everywhereOnTypes replaceSaturatedTypeSynonym
70− where
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
82− in
83− saturateAllTypeSynonyms syns d
49+ go :: Int -> [Type] -> Type -> Either MultipleErrors (Maybe Type)
50+ go c args (TypeConstructor ctor)
51+ | Just (synArgs, body) <- M.lookup ctor (typeSynonyms env)
52+ , c == length synArgs
53+ = let repl = replaceAllTypeVars (zip (map fst synArgs) args) body
54+ in Just <$> try repl
55+ | Just (synArgs, _) <- M.lookup ctor (typeSynonyms env)
56+ , length synArgs > c
57+ = throwError . errorMessage $ PartiallyAppliedSynonym ctor
58+ go c args (TypeApp f arg) = go (c + 1) (arg : args) f
59+ go _ _ _ = return Nothing
8460
8561replaceAllTypeSynonyms :: (e ~ MultipleErrors, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
8662replaceAllTypeSynonyms d = do
8763 env <- getEnv
88− either (throwError . singleError) 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
64+ either throwError return $ replaceAllTypeSynonyms' env d
src/Language/PureScript/TypeChecker/Types.hs+6−29
@@ -67,24 +67,17 @@ import Language.PureScript.TypeChecker.Synonyms
6767import Language.PureScript.TypeChecker.Unify
6868import Language.PureScript.TypeClassDictionaries
6969import Language.PureScript.Types
70−import qualified Language.PureScript.Constants as C
7170
7271-- |
7372-- Infer the types of multiple mutually-recursive values, and return elaborated values including
7473-- type class dictionaries and type annotations.
7574--
76−typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Expr)] -> Check [(Ident, (Expr, Type))]
77−typesOf mainModuleName moduleName vals = do
75+typesOf :: ModuleName -> [(Ident, Expr)] -> Check [(Ident, (Expr, Type))]
76+typesOf moduleName vals = do
7877 tys <- fmap tidyUp . liftUnifyWarnings replace $ do
7978 (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals
80− ds1 <- parU typed $ \e -> do
81− triple@(_, (_, ty)) <- 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
86− checkMain (fst e) ty
87− return triple
79+ ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict
80+ ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict
8881 return $ ds1 ++ ds2
8982
9083 forM tys $ \(ident, (val, ty)) -> do
@@ -94,21 +87,13 @@ typesOf mainModuleName moduleName vals = do
9487 skolemEscapeCheck val'
9588 -- Check rows do not contain duplicate labels
9689 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))
10291 where
10392 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
10493 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts
10594 -- Replace all the wildcards types with their inferred types
10695 replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints $ WildcardInferredType (sub $? ty)
10796 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
11297
11398type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)
11499
@@ -182,9 +167,7 @@ replaceTypeClassDictionaries mn =
182167 let (_, f, _) = everywhereOnValuesTopDownM return go return
183168 in f
184169 where
185− go (TypeClassDictionary constraint dicts) = do
186− env <- getEnv
187− entails env mn dicts constraint
170+ go (TypeClassDictionary constraint dicts) = entails mn dicts constraint
188171 go other = return other
189172
190173-- |
@@ -473,9 +456,6 @@ check' val t@(ConstrainedType constraints ty) = do
473456
474457 instantiateSuperclass :: [String] -> [Type] -> [Type] -> [Type]
475458 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
479459check' val u@(TUnknown _) = do
480460 val'@(TypedValue _ _ ty) <- infer val
481461 -- Don't unify an unknown with an inferred polytype
@@ -654,9 +634,6 @@ checkFunctionApplication' fn u@(TUnknown _) arg ret = do
654634 ret' <- maybe fresh return ret
655635 u =?= function ty ret'
656636 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
660637checkFunctionApplication' fn (KindedType ty _) arg ret =
661638 checkFunctionApplication fn ty arg ret
662639checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do
src/Language/PureScript/TypeChecker/Unify.hs+10−25
@@ -36,11 +36,9 @@ import Control.Monad.Unify
3636import Control.Monad.Writer
3737import Control.Monad.Error.Class (MonadError(..))
3838
39−import Language.PureScript.Environment
4039import Language.PureScript.Errors
4140import Language.PureScript.TypeChecker.Monad
4241import Language.PureScript.TypeChecker.Skolems
43−import Language.PureScript.TypeChecker.Synonyms
4442import Language.PureScript.Types
4543
4644instance Partial Type where
@@ -69,10 +67,6 @@ unifyTypes t1 t2 = rethrow (addHint (ErrorUnifyingTypes t1 t2)) $
6967 unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()
7068 unifyTypes' (TUnknown u) t = u =:= t
7169 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
7670 unifyTypes' (ForAll ident1 ty1 sc1) (ForAll ident2 ty2 sc2) =
7771 case (sc1, sc2) of
7872 (Just sc1', Just sc2') -> do
@@ -132,10 +126,6 @@ unifyRows r1 r2 =
132126 rest <- fresh
133127 u1 =:= rowFromList (sd2, rest)
134128 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'
139129 unifyRows' [] REmpty [] REmpty = return ()
140130 unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()
141131 unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return ()
@@ -144,26 +134,21 @@ unifyRows r1 r2 =
144134-- |
145135-- Check that two types unify
146136--
147−unifiesWith :: Environment -> Type -> Type -> Bool
148−unifiesWith _ (TUnknown u1) (TUnknown u2) | u1 == u2 = True
149−unifiesWith _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = True
150−unifiesWith _ (TypeVar v1) (TypeVar v2) | v1 == v2 = True
151−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
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
159−unifiesWith e r1@RCons{} r2@RCons{} =
137+unifiesWith :: Type -> Type -> Bool
138+unifiesWith (TUnknown u1) (TUnknown u2) | u1 == u2 = True
139+unifiesWith (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = True
140+unifiesWith (TypeVar v1) (TypeVar v2) | v1 == v2 = True
141+unifiesWith (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True
142+unifiesWith (TypeApp h1 t1) (TypeApp h2 t2) = h1 `unifiesWith` h2 && t1 `unifiesWith` t2
143+unifiesWith REmpty REmpty = True
144+unifiesWith r1@RCons{} r2@RCons{} =
160145 let (s1, r1') = rowToList r1
161146 (s2, r2') = rowToList r2
162147
163148 int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
164149 sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
165150 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'
167152 where
168153 go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Bool
169154 go [] REmpty [] REmpty = True
@@ -173,7 +158,7 @@ unifiesWith e r1@RCons{} r2@RCons{} =
173158 go _ _ [] (TUnknown _) = True
174159 go _ (TUnknown _) _ (TUnknown _) = True
175160 go _ _ _ _ = False
176−unifiesWith _ _ _ = False
161+unifiesWith _ _ = False
177162
178163-- |
179164-- Replace a single type variable with a new unification variable
src/Language/PureScript/Types.hs−12
@@ -67,10 +67,6 @@ data Type
6767 --
6868 | TypeApp Type Type
6969 -- |
70− -- A type synonym which is \"saturated\", i.e. fully applied
71− --
72− | SaturatedTypeSynonym (Qualified ProperName) [Type]
73− -- |
7470 -- Forall quantifier
7571 --
7672 | ForAll String Type (Maybe SkolemScope)
@@ -159,7 +155,6 @@ replaceAllTypeVars = go []
159155 go :: [String] -> [(String, Type)] -> Type -> Type
160156 go _ m (TypeVar v) = fromMaybe (TypeVar v) (v `lookup` m)
161157 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
163158 go bs m f@(ForAll v t sco) | v `elem` keys = go bs (filter ((/= v) . fst) m) f
164159 | v `elem` usedVars =
165160 let v' = genName v (keys ++ bs ++ usedVars)
@@ -198,7 +193,6 @@ freeTypeVariables = nub . go []
198193 go :: [String] -> Type -> [String]
199194 go bound (TypeVar v) | v `notElem` bound = [v]
200195 go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2
201− go bound (SaturatedTypeSynonym _ ts) = concatMap (go bound) ts
202196 go bound (ForAll v t _) = go (v : bound) t
203197 go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) . snd) cs ++ go bound t
204198 go bound (RCons _ t r) = go bound t ++ go bound r
@@ -245,7 +239,6 @@ everywhereOnTypes :: (Type -> Type) -> Type -> Type
245239everywhereOnTypes f = go
246240 where
247241 go (TypeApp t1 t2) = f (TypeApp (go t1) (go t2))
248− go (SaturatedTypeSynonym name tys) = f (SaturatedTypeSynonym name (map go tys))
249242 go (ForAll arg ty sco) = f (ForAll arg (go ty) sco)
250243 go (ConstrainedType cs ty) = f (ConstrainedType (map (fmap (map go)) cs) (go ty))
251244 go (RCons name ty rest) = f (RCons name (go ty) (go rest))
@@ -259,7 +252,6 @@ everywhereOnTypesTopDown :: (Type -> Type) -> Type -> Type
259252everywhereOnTypesTopDown f = go . f
260253 where
261254 go (TypeApp t1 t2) = TypeApp (go (f t1)) (go (f t2))
262− go (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym name (map (go . f) tys)
263255 go (ForAll arg ty sco) = ForAll arg (go (f ty)) sco
264256 go (ConstrainedType cs ty) = ConstrainedType (map (fmap (map (go . f))) cs) (go (f ty))
265257 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) ->
273265everywhereOnTypesM f = go
274266 where
275267 go (TypeApp t1 t2) = (TypeApp <$> go t1 <*> go t2) >>= f
276− go (SaturatedTypeSynonym name tys) = (SaturatedTypeSynonym name <$> mapM go tys) >>= f
277268 go (ForAll arg ty sco) = (ForAll arg <$> go ty <*> pure sco) >>= f
278269 go (ConstrainedType cs ty) = (ConstrainedType <$> mapM (sndM (mapM go)) cs <*> go ty) >>= f
279270 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
287278everywhereOnTypesTopDownM f = go <=< f
288279 where
289280 go (TypeApp t1 t2) = TypeApp <$> (f t1 >>= go) <*> (f t2 >>= go)
290− go (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym name <$> mapM (go <=< f) tys
291281 go (ForAll arg ty sco) = ForAll arg <$> (f ty >>= go) <*> pure sco
292282 go (ConstrainedType cs ty) = ConstrainedType <$> mapM (sndM (mapM (go <=< f))) cs <*> (f ty >>= go)
293283 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
301291everythingOnTypes (<>) f = go
302292 where
303293 go t@(TypeApp t1 t2) = f t <> go t1 <> go t2
304− go t@(SaturatedTypeSynonym _ tys) = foldl (<>) (f t) (map go tys)
305294 go t@(ForAll _ ty _) = f t <> go ty
306295 go t@(ConstrainedType cs ty) = foldl (<>) (f t) (map go $ concatMap snd cs) <> go ty
307296 go t@(RCons _ ty rest) = f t <> go ty <> go rest
@@ -316,7 +305,6 @@ everythingWithContextOnTypes s0 r0 (<>) f = go' s0
316305 where
317306 go' s t = let (s', r) = f s t in r <> go s' t
318307 go s (TypeApp t1 t2) = go' s t1 <> go' s t2
319− go s (SaturatedTypeSynonym _ tys) = foldl (<>) r0 (map (go' s) tys)
320308 go s (ForAll _ ty _) = go' s ty
321309 go s (ConstrainedType cs ty) = foldl (<>) r0 (map (go' s) $ concatMap snd cs) <> go' s ty
322310 go s (RCons _ ty rest) = go' s ty <> go' s rest