a467358 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Merge remote-tracking branch 'upstream/master' into pure11-0.8

a467358Andy Arvanitis11 years ago

CONTRIBUTORS.md+1

@@ -51,6 +51,7 @@ This file lists the contributors to the PureScript compiler project, and the ter

51- [@robdaemon](https://github.com/robdaemon) (Robert Roland) My existing contributions and all future contributions until further notice are Copyright Robert Roland, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

52- [@RossMeikleham](https://github.com/RossMeikleham) (Ross Meikleham) My existing contributions and all future contributions until further notice are Copyright Ross Meikleham, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

53- [@sebastiaanvisser](https://github.com/sebastiaanvisser) (Sebastiaan Visser) - My existing contributions and all future contributions until further notice are Copyright Sebastiaan Visser, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.

54+- [@sharkdp](https://github.com/sharkdp) (David Peter) My existing contributions and all future contributions until further notice are Copyright David Peter, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

54- [@sztupi](https://github.com/sztupi) (Attila Sztupak) My existing contributions and all future contributions until further notice are Copyright Attila Sztupak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

55- [@sztupi](https://github.com/sztupi) (Attila Sztupak) My existing contributions and all future contributions until further notice are Copyright Attila Sztupak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

55- [@taku0](https://github.com/taku0) - My existing contributions and all future contributions until further notice are Copyright taku0, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

56- [@taku0](https://github.com/taku0) - My existing contributions and all future contributions until further notice are Copyright taku0, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

56- [@trofi](https://github.com/trofi) (Sergei Trofimovich) My existing contributions and all future contributions until further notice are Copyright Sergei Trofimovich, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

57- [@trofi](https://github.com/trofi) (Sergei Trofimovich) My existing contributions and all future contributions until further notice are Copyright Sergei Trofimovich, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

examples/docs/src/ImportedTwice.pursnew file+27

@@ -0,0 +1,27 @@

1+-- See also an example in the wild: purescript-transformers v0.8.4.

2+-- Control.Monad.RWS.Trans re-exports `lift` from both Control.Monad.Trans

3+-- (where it is originally defined) and Control.Monad.RWS.Class (which

4+-- re-exports it from Control.Monad.Trans).

6+module ImportedTwice

7+ ( module A

8+ , module B

9+ )

10+ where

11+

12+import A

13+import B

14+

15+module A

16+ ( module B )

17+ where

18+

19+import B

20+

21+bar :: Int

22+bar = 1

23+

24+module B where

25+

26+foo :: Int

27+foo = 0

psci/PSCi.hs+17−4

@@ -14,7 +14,7 @@ import Prelude.Compat

15import Data.Foldable (traverse_)

16import Data.Maybe (mapMaybe)

17−import Data.List (intersperse, intercalate, nub, sort)

17+import Data.List (intersperse, intercalate, nub, sort, find)

18import Data.Tuple (swap)

19import Data.Version (showVersion)

20import qualified Data.Map as M

@@ -486,9 +486,22 @@ handleBrowse moduleName = do

486 case env of

487 Left errs -> printErrors errs

488 Right env' ->

489− if moduleName `notElem` (nub . map ((\ (P.Module _ _ modName _ _ ) -> modName) . snd)) (psciLoadedModules st)

489+ if isModInEnv moduleName st

490+ then printModuleSignatures moduleName env'

491+ else case lookupUnQualifiedModName moduleName st of

492+ Just unQualifiedName ->

493+ if isModInEnv unQualifiedName st

494+ then printModuleSignatures unQualifiedName env'

495+ else failNotInEnv moduleName

496+ Nothing ->

497+ failNotInEnv moduleName

498+ where

499+ isModInEnv modName =

500+ any ((== modName) . P.getModuleName . snd) . psciLoadedModules

501+ failNotInEnv modName =

490− then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."

502+ PSCI $ outputStrLn $ "Module '" ++ N.runModuleName modName ++ "' is not valid."

491− else printModuleSignatures moduleName env'

503+ lookupUnQualifiedModName quaModName st =

504+ (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st)

492

505

493-- | Pretty-print errors

506-- | Pretty-print errors

494printErrors :: P.MultipleErrors -> PSCI ()

507printErrors :: P.MultipleErrors -> PSCI ()

src/Language/PureScript/CodeGen/JS/Optimizer.hs+5−17

@@ -1,13 +1,5 @@

1−-----------------------------------------------------------------------------

1+{-# LANGUAGE FlexibleContexts #-}

2−--

3−-- Module : Language.PureScript.CodeGen.JS.Optimizer

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11-- |

3-- |

12-- This module optimizes code in the simplified-Javascript intermediate representation.

4-- This module optimizes code in the simplified-Javascript intermediate representation.

13--

5--

@@ -29,13 +21,7 @@

29--

21--

30-- * Inlining primitive Javascript operators

22-- * Inlining primitive Javascript operators

31--

23--

32−-----------------------------------------------------------------------------

33−

34−{-# LANGUAGE FlexibleContexts #-}

35−

36−module Language.PureScript.CodeGen.JS.Optimizer (

24+module Language.PureScript.CodeGen.JS.Optimizer (optimize) where

37− optimize

38−) where

40import Prelude ()

26import Prelude ()

41import Prelude.Compat

27import Prelude.Compat

@@ -79,7 +65,9 @@ optimize' js = do

79 , inlineVariables

65 , inlineVariables

80 , inlineValues

66 , inlineValues

81 , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]

67 , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]

68+ , inlineOperator (C.dataFunction, C.apply) $ \f x -> JSApp f [x]

82 , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]

69 , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]

70+ , inlineOperator (C.dataFunction, C.applyFlipped) $ \x f -> JSApp f [x]

83 , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip JSIndexer

71 , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip JSIndexer

84 , inlineCommonOperators ]) js

72 , inlineCommonOperators ]) js

src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs+15−12

@@ -1,18 +1,6 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.CodeGen.JS.Optimizer.Common

4−-- Copyright : (c) Phil Freeman 2013-14

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11-- |

1-- |

12-- Common functions used by the various optimizer phases

2-- Common functions used by the various optimizer phases

13--

3--

14−-----------------------------------------------------------------------------

15−

16module Language.PureScript.CodeGen.JS.Optimizer.Common where

4module Language.PureScript.CodeGen.JS.Optimizer.Common where

18import Data.Maybe (fromMaybe)

6import Data.Maybe (fromMaybe)

@@ -76,3 +64,18 @@ isUpdated var1 = everythingOnJS (||) check

76removeFromBlock :: ([JS] -> [JS]) -> JS -> JS

64removeFromBlock :: ([JS] -> [JS]) -> JS -> JS

77removeFromBlock go (JSBlock sts) = JSBlock (go sts)

65removeFromBlock go (JSBlock sts) = JSBlock (go sts)

78removeFromBlock _ js = js

66removeFromBlock _ js = js

67+

68+isFn :: (String, String) -> JS -> Bool

69+isFn (moduleName, fnName) (JSAccessor x (JSVar y)) = x == fnName && y == moduleName

70+isFn (moduleName, fnName) (JSIndexer (JSStringLiteral x) (JSVar y)) = x == fnName && y == moduleName

71+isFn _ _ = False

72+

73+isFn' :: [(String, String)] -> JS -> Bool

74+isFn' xs js = any (`isFn` js) xs

75+

76+isDict :: (String, String) -> JS -> Bool

77+isDict (moduleName, dictName) (JSAccessor x (JSVar y)) = x == dictName && y == moduleName

78+isDict _ _ = False

79+

80+isDict' :: [(String, String)] -> JS -> Bool

81+isDict' xs js = any (`isDict` js) xs

src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs+188−136

@@ -1,28 +1,16 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.CodeGen.JS.Optimizer.Inliner

4−-- Copyright : (c) Phil Freeman 2013-14

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11-- |

1-- |

12-- This module provides basic inlining capabilities

2-- This module provides basic inlining capabilities

13--

3--

14−-----------------------------------------------------------------------------

15−

16−module Language.PureScript.CodeGen.JS.Optimizer.Inliner (

4+module Language.PureScript.CodeGen.JS.Optimizer.Inliner

17− inlineVariables,

5+ ( inlineVariables

18− inlineValues,

6+ , inlineValues

19− inlineOperator,

7+ , inlineOperator

20− inlineCommonOperators,

8+ , inlineCommonOperators

21− inlineFnComposition,

9+ , inlineFnComposition

22− etaConvert,

10+ , etaConvert

23− unThunk,

11+ , unThunk

24− evaluateIifes

12+ , evaluateIifes

25−) where

13+ ) where

27import Prelude ()

15import Prelude ()

28import Prelude.Compat

16import Prelude.Compat

@@ -93,26 +81,26 @@ inlineValues :: JS -> JS

93inlineValues = everywhereOnJS convert

81inlineValues = everywhereOnJS convert

94 where

82 where

95 convert :: JS -> JS

83 convert :: JS -> JS

96− convert (JSApp fn [dict]) | isDict semiringNumber dict && isFn fnZero fn = JSNumericLiteral (Left 0)

84+ convert (JSApp fn [dict])

97− | isDict semiringNumber dict && isFn fnOne fn = JSNumericLiteral (Left 1)

98− | isDict semiringInt dict && isFn fnZero fn = JSNumericLiteral (Left 0)

85+ | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnZero fn = JSNumericLiteral (Left 0)

99− | isDict semiringInt dict && isFn fnOne fn = JSNumericLiteral (Left 1)

86+ | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnOne fn = JSNumericLiteral (Left 1)

100− | isDict boundedBoolean dict && isFn fnBottom fn = JSBooleanLiteral False

87+ | isDict' boundedBoolean dict && isFn' fnBottom fn = JSBooleanLiteral False

101− | isDict boundedBoolean dict && isFn fnTop fn = JSBooleanLiteral True

88+ | isDict' boundedBoolean dict && isFn' fnTop fn = JSBooleanLiteral True

102 convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y])

89 convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y])

103− | isDict semiringInt dict && isFn fnAdd fn = JSBinary BitwiseOr (JSBinary Add x y) (JSNumericLiteral (Left 0))

90+ | isDict' semiringInt dict && isFn' fnAdd fn = intOp Add x y

104− | isDict semiringInt dict && isFn fnMultiply fn = JSBinary BitwiseOr (JSBinary Multiply x y) (JSNumericLiteral (Left 0))

91+ | isDict' semiringInt dict && isFn' fnMultiply fn = intOp Multiply x y

105− | isDict moduloSemiringInt dict && isFn fnDivide fn = JSBinary BitwiseOr (JSBinary Divide x y) (JSNumericLiteral (Left 0))

92+ | isDict' moduloSemiringInt dict && isFn' fnDivide fn = intOp Divide x y

106− | isDict ringInt dict && isFn fnSubtract fn = JSBinary BitwiseOr (JSBinary Subtract x y) (JSNumericLiteral (Left 0))

93+ | isDict' ringInt dict && isFn' fnSubtract fn = intOp Subtract x y

107 convert other = other

94 convert other = other

108− fnZero = (C.prelude, C.zero)

95+ fnZero = [(C.prelude, C.zero), (C.dataSemiring, C.zero)]

109− fnOne = (C.prelude, C.one)

96+ fnOne = [(C.prelude, C.one), (C.dataSemiring, C.one)]

110− fnBottom = (C.prelude, C.bottom)

97+ fnBottom = [(C.prelude, C.bottom), (C.dataBounded, C.bottom)]

111− fnTop = (C.prelude, C.top)

98+ fnTop = [(C.prelude, C.top), (C.dataBounded, C.top)]

112− fnAdd = (C.prelude, (C.+))

99+ fnAdd = [(C.prelude, (C.+)), (C.prelude, (C.add)), (C.dataSemiring, (C.+)), (C.dataSemiring, (C.add))]

113− fnDivide = (C.prelude, (C./))

100+ fnDivide = [(C.prelude, (C./)), (C.prelude, (C.div)), (C.dataModuloSemiring, C.div)]

114− fnMultiply = (C.prelude, (C.*))

101+ fnMultiply = [(C.prelude, (C.*)), (C.prelude, (C.mul)), (C.dataSemiring, (C.*)), (C.dataSemiring, (C.mul))]

115− fnSubtract = (C.prelude, (C.-))

102+ fnSubtract = [(C.prelude, (C.-)), (C.prelude, C.sub), (C.dataRing, C.sub)]

103+ intOp op x y = JSBinary BitwiseOr (JSBinary op x y) (JSNumericLiteral (Left 0))

116

104

117inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS

105inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS

118inlineOperator (m, op) f = everywhereOnJS convert

106inlineOperator (m, op) f = everywhereOnJS convert

@@ -126,43 +114,54 @@ inlineOperator (m, op) f = everywhereOnJS convert

126

114

127inlineCommonOperators :: JS -> JS

115inlineCommonOperators :: JS -> JS

128inlineCommonOperators = applyAll $

116inlineCommonOperators = applyAll $

129− [ binary semiringNumber (C.+) Add

117+ [ binary semiringNumber opAdd Add

130− , binary semiringNumber (C.*) Multiply

118+ , binary semiringNumber opMul Multiply

131−

119+

132− , binary ringNumber (C.-) Subtract

120+ , binary ringNumber opSub Subtract

133− , unary ringNumber C.negate Negate

121+ , unary ringNumber opNegate Negate

134− , binary ringInt (C.-) Subtract

122+ , binary ringInt opSub Subtract

135− , unary ringInt C.negate Negate

123+ , unary ringInt opNegate Negate

136−

124+

137− , binary moduloSemiringNumber (C./) Divide

125+ , binary moduloSemiringNumber opDiv Divide

138− , binary moduloSemiringInt C.mod Modulus

126+ , binary moduloSemiringInt opMod Modulus

139−

127+

140− , binary eqNumber (C.==) EqualTo

128+ , binary eqNumber opEq EqualTo

141− , binary eqNumber (C./=) NotEqualTo

129+ , binary eqNumber opNotEq NotEqualTo

142− , binary eqInt (C.==) EqualTo

130+ , binary eqInt opEq EqualTo

143− , binary eqInt (C./=) NotEqualTo

131+ , binary eqInt opNotEq NotEqualTo

144− , binary eqString (C.==) EqualTo

132+ , binary eqString opEq EqualTo

145− , binary eqString (C./=) NotEqualTo

133+ , binary eqString opNotEq NotEqualTo

134+ , binary eqChar opEq EqualTo

135+ , binary eqChar opNotEq NotEqualTo

146− , binary eqBoolean (C.==) EqualTo

136+ , binary eqBoolean opEq EqualTo

147− , binary eqBoolean (C./=) NotEqualTo

137+ , binary eqBoolean opNotEq NotEqualTo

148−

138+

149− , binary ordNumber (C.<) LessThan

139+ , binary ordBoolean opLessThan LessThan

150− , binary ordNumber (C.>) GreaterThan

140+ , binary ordBoolean opLessThanOrEq LessThanOrEqualTo

141+ , binary ordBoolean opGreaterThan GreaterThan

142+ , binary ordBoolean opGreaterThanOrEq GreaterThanOrEqualTo

143+ , binary ordChar opLessThan LessThan

151− , binary ordNumber (C.<=) LessThanOrEqualTo

144+ , binary ordChar opLessThanOrEq LessThanOrEqualTo

145+ , binary ordChar opGreaterThan GreaterThan

152− , binary ordNumber (C.>=) GreaterThanOrEqualTo

146+ , binary ordChar opGreaterThanOrEq GreaterThanOrEqualTo

153− , binary ordInt (C.<) LessThan

147+ , binary ordInt opLessThan LessThan

154− , binary ordInt (C.>) GreaterThan

148+ , binary ordInt opLessThanOrEq LessThanOrEqualTo

155− , binary ordInt (C.<=) LessThanOrEqualTo

149+ , binary ordInt opGreaterThan GreaterThan

156− , binary ordInt (C.>=) GreaterThanOrEqualTo

150+ , binary ordInt opGreaterThanOrEq GreaterThanOrEqualTo

157−

151+ , binary ordNumber opLessThan LessThan

158− , binary semigroupString (C.<>) Add

152+ , binary ordNumber opLessThanOrEq LessThanOrEqualTo

159− , binary semigroupString (C.++) Add

153+ , binary ordNumber opGreaterThan GreaterThan

160−

154+ , binary ordNumber opGreaterThanOrEq GreaterThanOrEqualTo

161− , binary booleanAlgebraBoolean (C.&&) And

155+ , binary ordString opLessThan LessThan

162− , binary booleanAlgebraBoolean (C.||) Or

156+ , binary ordString opLessThanOrEq LessThanOrEqualTo

157+ , binary ordString opGreaterThan GreaterThan

158+ , binary ordString opGreaterThanOrEq GreaterThanOrEqualTo

159+

160+ , binary semigroupString opAppend Add

161+

163− , binaryFunction booleanAlgebraBoolean C.conj And

162+ , binary booleanAlgebraBoolean opConj And

164− , binaryFunction booleanAlgebraBoolean C.disj Or

163+ , binary booleanAlgebraBoolean opDisj Or

165− , unary booleanAlgebraBoolean C.not Not

164+ , unary booleanAlgebraBoolean opNot Not

166

165

167 , binary' C.dataIntBits (C..|.) BitwiseOr

166 , binary' C.dataIntBits (C..|.) BitwiseOr

168 , binary' C.dataIntBits (C..&.) BitwiseAnd

167 , binary' C.dataIntBits (C..&.) BitwiseAnd

@@ -174,11 +173,11 @@ inlineCommonOperators = applyAll $

174 ] ++

173 ] ++

175 [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]

174 [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]

176 where

175 where

177− binary :: (String, String) -> String -> BinaryOperator -> JS -> JS

176+ binary :: [(String, String)] -> [(String, String)] -> BinaryOperator -> JS -> JS

178− binary dict opString op = everywhereOnJS convert

177+ binary dict fns op = everywhereOnJS convert

179 where

178 where

180 convert :: JS -> JS

179 convert :: JS -> JS

181− convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isDict dict dict' && isPreludeFn opString fn = JSBinary op x y

180+ convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isDict' dict dict' && isFn' fns fn = JSBinary op x y

182 convert other = other

181 convert other = other

183 binary' :: String -> String -> BinaryOperator -> JS -> JS

182 binary' :: String -> String -> BinaryOperator -> JS -> JS

184 binary' moduleName opString op = everywhereOnJS convert

183 binary' moduleName opString op = everywhereOnJS convert

@@ -186,17 +185,11 @@ inlineCommonOperators = applyAll $

186 convert :: JS -> JS

185 convert :: JS -> JS

187 convert (JSApp (JSApp fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary op x y

186 convert (JSApp (JSApp fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary op x y

188 convert other = other

187 convert other = other

189− binaryFunction :: (String, String) -> String -> BinaryOperator -> JS -> JS

190− binaryFunction dict fnName op = everywhereOnJS convert

191− where

192− convert :: JS -> JS

193− convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isPreludeFn fnName fn && isDict dict dict' = JSBinary op x y

194− convert other = other

195− unary :: (String, String) -> String -> UnaryOperator -> JS -> JS

188+ unary :: [(String, String)] -> [(String, String)] -> UnaryOperator -> JS -> JS

196− unary dict fnName op = everywhereOnJS convert

189+ unary dicts fns op = everywhereOnJS convert

197 where

190 where

198 convert :: JS -> JS

191 convert :: JS -> JS

199− convert (JSApp (JSApp fn [dict']) [x]) | isPreludeFn fnName fn && isDict dict dict' = JSUnary op x

192+ convert (JSApp (JSApp fn [dict']) [x]) | isDict' dicts dict' && isFn' fns fn = JSUnary op x

200 convert other = other

193 convert other = other

201 unary' :: String -> String -> UnaryOperator -> JS -> JS

194 unary' :: String -> String -> UnaryOperator -> JS -> JS

202 unary' moduleName fnName op = everywhereOnJS convert

195 unary' moduleName fnName op = everywhereOnJS convert

@@ -246,71 +239,130 @@ inlineFnComposition :: (Applicative m, MonadSupply m) => JS -> m JS

246inlineFnComposition = everywhereOnJSTopDownM convert

239inlineFnComposition = everywhereOnJSTopDownM convert

247 where

240 where

248 convert :: (MonadSupply m) => JS -> m JS

241 convert :: (MonadSupply m) => JS -> m JS

249− convert (JSApp (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) [z]) | isFnCompose dict' fn =

242+ convert (JSApp (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) [z])

243+ | isFnCompose dict' fn = return $ JSApp x [JSApp y [z]]

250− return $ JSApp x [JSApp y [z]]

244+ | isFnComposeFlipped dict' fn = return $ JSApp y [JSApp x [z]]

251− convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isFnCompose dict' fn = do

245+ convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y])

246+ | isFnCompose dict' fn = do

252− arg <- freshName

247+ arg <- freshName

253− return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp x [JSApp y [JSVar arg]]])

248+ return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp x [JSApp y [JSVar arg]]])

249+ | isFnComposeFlipped dict' fn = do

250+ arg <- freshName

251+ return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp y [JSApp x [JSVar arg]]])

254 convert other = return other

252 convert other = return other

255 isFnCompose :: JS -> JS -> Bool

253 isFnCompose :: JS -> JS -> Bool

256− isFnCompose dict' fn = isDict semigroupoidFn dict' && (isPreludeFn (C.<<<) fn || isPreludeFn C.compose fn)

254+ isFnCompose dict' fn = isDict' semigroupoidFn dict' && isFn' fnCompose fn

255+ isFnComposeFlipped :: JS -> JS -> Bool

256+ isFnComposeFlipped dict' fn = isDict' semigroupoidFn dict' && isFn' fnComposeFlipped fn

257+ fnCompose :: [(String, String)]

258+ fnCompose = [(C.prelude, C.compose), (C.prelude, (C.<<<)), (C.controlSemigroupoid, C.compose)]

259+ fnComposeFlipped :: [(String, String)]

260+ fnComposeFlipped = [(C.prelude, (C.>>>)), (C.controlSemigroupoid, C.composeFlipped)]

261+

262+semiringNumber :: [(String, String)]

263+semiringNumber = [(C.prelude, C.semiringNumber), (C.dataSemiring, C.semiringNumber)]

264+

265+semiringInt :: [(String, String)]

266+semiringInt = [(C.prelude, C.semiringInt), (C.dataSemiring, C.semiringInt)]

267+

268+ringNumber :: [(String, String)]

269+ringNumber = [(C.prelude, C.ringNumber), (C.dataRing, C.ringNumber)]

270+

271+ringInt :: [(String, String)]

272+ringInt = [(C.prelude, C.ringInt), (C.dataRing, C.ringInt)]

273+

274+moduloSemiringNumber :: [(String, String)]

275+moduloSemiringNumber = [(C.prelude, C.moduloSemiringNumber), (C.dataModuloSemiring, C.moduloSemiringNumber)]

276+

277+moduloSemiringInt :: [(String, String)]

278+moduloSemiringInt = [(C.prelude, C.moduloSemiringInt), (C.dataModuloSemiring, C.moduloSemiringInt)]

279+

280+eqNumber :: [(String, String)]

281+eqNumber = [(C.prelude, C.eqNumber), (C.dataEq, C.eqNumber)]

282+

283+eqInt :: [(String, String)]

284+eqInt = [(C.prelude, C.eqInt), (C.dataEq, C.eqInt)]

285+

286+eqString :: [(String, String)]

287+eqString = [(C.prelude, C.eqString), (C.dataEq, C.eqString)]

288+

289+eqChar :: [(String, String)]

290+eqChar = [(C.prelude, C.eqChar), (C.dataEq, C.eqChar)]

291+

292+eqBoolean :: [(String, String)]

293+eqBoolean = [(C.prelude, C.eqBoolean), (C.dataEq, C.eqBoolean)]

294+

295+ordBoolean :: [(String, String)]

296+ordBoolean = [(C.prelude, C.ordBoolean), (C.dataOrd, C.ordBoolean)]

297+

298+ordNumber :: [(String, String)]

299+ordNumber = [(C.prelude, C.ordNumber), (C.dataOrd, C.ordNumber)]

300+

301+ordInt :: [(String, String)]

302+ordInt = [(C.prelude, C.ordInt), (C.dataOrd, C.ordInt)]

303+

304+ordString :: [(String, String)]

305+ordString = [(C.prelude, C.ordString), (C.dataOrd, C.ordString)]

306+

307+ordChar :: [(String, String)]

308+ordChar = [(C.prelude, C.ordChar), (C.dataOrd, C.ordChar)]

309+

310+semigroupString :: [(String, String)]

311+semigroupString = [(C.prelude, C.semigroupString), (C.dataSemigroup, C.semigroupString)]

257

312

258−isDict :: (String, String) -> JS -> Bool

313+boundedBoolean :: [(String, String)]

259−isDict (moduleName, dictName) (JSAccessor x (JSVar y)) = x == dictName && y == moduleName

314+boundedBoolean = [(C.prelude, C.boundedBoolean), (C.dataBounded, C.boundedBoolean)]

260−isDict _ _ = False

261

315

262−isFn :: (String, String) -> JS -> Bool

316+booleanAlgebraBoolean :: [(String, String)]

263−isFn (moduleName, fnName) (JSAccessor x (JSVar y)) = x == fnName && y == moduleName

317+booleanAlgebraBoolean = [(C.prelude, C.booleanAlgebraBoolean), (C.dataBooleanAlgebra, C.booleanAlgebraBoolean)]

264−isFn (moduleName, fnName) (JSIndexer (JSStringLiteral x) (JSVar y)) = x == fnName && y == moduleName

265−isFn _ _ = False

266

318

267−isPreludeFn :: String -> JS -> Bool

319+semigroupoidFn :: [(String, String)]

268−isPreludeFn fnName = isFn (C.prelude, fnName)

320+semigroupoidFn = [(C.prelude, C.semigroupoidFn), (C.controlSemigroupoid, C.semigroupoidFn)]

269

321

270−semiringNumber :: (String, String)

322+opAdd :: [(String, String)]

271−semiringNumber = (C.prelude, C.semiringNumber)

323+opAdd = [(C.prelude, (C.+)), (C.prelude, C.add), (C.dataSemiring, C.add)]

272

324

273−semiringInt :: (String, String)

325+opMul :: [(String, String)]

274−semiringInt = (C.prelude, C.semiringInt)

326+opMul = [(C.prelude, (C.*)), (C.prelude, C.mul), (C.dataSemiring, C.mul)]

275

327

276−ringNumber :: (String, String)

328+opEq :: [(String, String)]

277−ringNumber = (C.prelude, C.ringNumber)

329+opEq = [(C.prelude, (C.==)), (C.prelude, C.eq), (C.dataEq, C.eq)]

278

330

279−ringInt :: (String, String)

331+opNotEq :: [(String, String)]

280−ringInt = (C.prelude, C.ringInt)

332+opNotEq = [(C.prelude, (C./=)), (C.dataEq, C.notEq)]

281

333

282−moduloSemiringNumber :: (String, String)

334+opLessThan :: [(String, String)]

283−moduloSemiringNumber = (C.prelude, C.moduloSemiringNumber)

335+opLessThan = [(C.prelude, (C.<)), (C.dataOrd, C.lessThan)]

284

336

285−moduloSemiringInt :: (String, String)

337+opLessThanOrEq :: [(String, String)]

286−moduloSemiringInt = (C.prelude, C.moduloSemiringInt)

338+opLessThanOrEq = [(C.prelude, (C.<=)), (C.dataOrd, C.lessThanOrEq)]

287

339

288−eqNumber :: (String, String)

340+opGreaterThan :: [(String, String)]

289−eqNumber = (C.prelude, C.eqNumber)

341+opGreaterThan = [(C.prelude, (C.>)), (C.dataOrd, C.greaterThan)]

290

342

291−eqInt :: (String, String)

343+opGreaterThanOrEq :: [(String, String)]

292−eqInt = (C.prelude, C.eqInt)

344+opGreaterThanOrEq = [(C.prelude, (C.>=)), (C.dataOrd, C.greaterThanOrEq)]

293

345

294−eqString :: (String, String)

346+opAppend :: [(String, String)]

295−eqString = (C.prelude, C.eqNumber)

347+opAppend = [(C.prelude, (C.<>)), (C.prelude, (C.++)), (C.prelude, C.append), (C.dataSemigroup, C.append)]

296

348

297−eqBoolean :: (String, String)

349+opSub :: [(String, String)]

298−eqBoolean = (C.prelude, C.eqNumber)

350+opSub = [(C.prelude, (C.-)), (C.prelude, C.sub), (C.dataRing, C.sub)]

299

351

300−ordNumber :: (String, String)

352+opNegate :: [(String, String)]

301−ordNumber = (C.prelude, C.ordNumber)

353+opNegate = [(C.prelude, C.negate), (C.dataRing, C.negate)]

302

354

303−ordInt :: (String, String)

355+opDiv :: [(String, String)]

304−ordInt = (C.prelude, C.ordInt)

356+opDiv = [(C.prelude, (C./)), (C.prelude, C.div), (C.dataModuloSemiring, C.div)]

305

357

306−semigroupString :: (String, String)

358+opMod :: [(String, String)]

307−semigroupString = (C.prelude, C.semigroupString)

359+opMod = [(C.prelude, C.mod), (C.dataModuloSemiring, C.mod)]

308

360

309−boundedBoolean :: (String, String)

361+opConj :: [(String, String)]

310−boundedBoolean = (C.prelude, C.boundedBoolean)

362+opConj = [(C.prelude, (C.&&)), (C.prelude, C.conj), (C.dataBooleanAlgebra, C.conj)]

311

363

312−booleanAlgebraBoolean :: (String, String)

364+opDisj :: [(String, String)]

313−booleanAlgebraBoolean = (C.prelude, C.booleanAlgebraBoolean)

365+opDisj = [(C.prelude, (C.||)), (C.prelude, C.disj), (C.dataBooleanAlgebra, C.disj)]

314

366

315−semigroupoidFn :: (String, String)

367+opNot :: [(String, String)]

316−semigroupoidFn = (C.prelude, C.semigroupoidFn)

368+opNot = [(C.prelude, C.not), (C.dataBooleanAlgebra, C.not)]

src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs+11−42

@@ -1,29 +1,14 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.CodeGen.JS.Optimizer.MagicDo

4−-- Copyright : (c) Phil Freeman 2013-14

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11-- |

1-- |

12-- This module implements the "Magic Do" optimization, which inlines calls to return

2-- This module implements the "Magic Do" optimization, which inlines calls to return

13-- and bind for the Eff monad, as well as some of its actions.

3-- and bind for the Eff monad, as well as some of its actions.

14--

4--

15−-----------------------------------------------------------------------------

16−

17−module Language.PureScript.CodeGen.JS.Optimizer.MagicDo (

5+module Language.PureScript.CodeGen.JS.Optimizer.MagicDo (magicDo) where

18− magicDo

19−) where

21import Data.List (nub)

7import Data.List (nub)

22import Data.Maybe (fromJust, isJust)

8import Data.Maybe (fromJust, isJust)

24import Language.PureScript.CodeGen.JS.AST

10import Language.PureScript.CodeGen.JS.AST

25−import Language.PureScript.CodeGen.JS.Common

11+import Language.PureScript.CodeGen.JS.Optimizer.Common

26−import Language.PureScript.Names

27import Language.PureScript.Options

12import Language.PureScript.Options

28import qualified Language.PureScript.Constants as C

13import qualified Language.PureScript.Constants as C

@@ -54,9 +39,7 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert

54 fnName = "__do"

39 fnName = "__do"

55 -- Desugar monomorphic calls to >>= and return for the Eff monad

40 -- Desugar monomorphic calls to >>= and return for the Eff monad

56 convert :: JS -> JS

41 convert :: JS -> JS

57− -- Desugar return

42+ -- Desugar pure & return

58− convert (JSApp (JSApp ret [val]) []) | isReturn ret = val

59− -- Desugar pure

60 convert (JSApp (JSApp pure' [val]) []) | isPure pure' = val

43 convert (JSApp (JSApp pure' [val]) []) | isPure pure' = val

61 -- Desugar >>

44 -- Desugar >>

62 convert (JSApp (JSApp bind [m]) [JSFunction Nothing [] (JSBlock js)]) | isBind bind =

45 convert (JSApp (JSApp bind [m]) [JSFunction Nothing [] (JSBlock js)]) | isBind bind =

@@ -72,33 +55,19 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert

72 JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn $ JSObjectLiteral []])) []

55 JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn $ JSObjectLiteral []])) []

73 convert other = other

56 convert other = other

74 -- Check if an expression represents a monomorphic call to >>= for the Eff monad

57 -- Check if an expression represents a monomorphic call to >>= for the Eff monad

75− isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict C.bindEffDictionary effDict = True

58+ isBind (JSApp fn [dict]) | isDict (C.eff, C.bindEffDictionary) dict && isBindPoly fn = True

76 isBind _ = False

59 isBind _ = False

77− -- Check if an expression represents a monomorphic call to return for the Eff monad

60+ -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative

78− isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict C.monadEffDictionary effDict = True

79− isReturn _ = False

80− -- Check if an expression represents a monomorphic call to pure for the Eff applicative

81− isPure (JSApp purePoly [effDict]) | isPurePoly purePoly && isEffDict C.applicativeEffDictionary effDict = True

61+ isPure (JSApp fn [dict]) | isDict (C.eff, C.applicativeEffDictionary) dict && isPurePoly fn = True

82 isPure _ = False

62 isPure _ = False

83 -- Check if an expression represents the polymorphic >>= function

63 -- Check if an expression represents the polymorphic >>= function

84− isBindPoly (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && (prop `elem` map identToJs [Ident C.bind, Op (C.>>=)])

64+ isBindPoly = isFn' [(C.prelude, C.bind), (C.prelude, (C.>>=)), (C.controlBind, C.bind)]

85− isBindPoly (JSIndexer (JSStringLiteral bind) (JSVar prelude)) = prelude == C.prelude && (bind `elem` [C.bind, (C.>>=)])

86− isBindPoly _ = False

87− -- Check if an expression represents the polymorphic return function

65+ -- Check if an expression represents the polymorphic pure or return function

88− isRetPoly (JSAccessor returnEscaped (JSVar prelude)) = prelude == C.prelude && returnEscaped == C.returnEscaped

66+ isPurePoly = isFn' [(C.prelude, C.pure'), (C.prelude, C.return), (C.controlApplicative, C.pure')]

89− isRetPoly (JSIndexer (JSStringLiteral return') (JSVar prelude)) = prelude == C.prelude && return' == C.return

90− isRetPoly _ = False

91− -- Check if an expression represents the polymorphic pure function

92− isPurePoly (JSAccessor pure' (JSVar prelude)) = prelude == C.prelude && pure' == C.pure'

93− isPurePoly (JSIndexer (JSStringLiteral pure') (JSVar prelude)) = prelude == C.prelude && pure' == C.pure'

94− isPurePoly _ = False

95− -- Check if an expression represents a function in the Ef module

67+ -- Check if an expression represents a function in the Eff module

96 isEffFunc name (JSAccessor name' (JSVar eff)) = eff == C.eff && name == name'

68 isEffFunc name (JSAccessor name' (JSVar eff)) = eff == C.eff && name == name'

97 isEffFunc _ _ = False

69 isEffFunc _ _ = False

98− -- Check if an expression represents the Monad Eff dictionary

70+

99− isEffDict name (JSVar ident) | ident == name = True

100− isEffDict name (JSAccessor prop (JSVar eff)) = eff == C.eff && prop == name

101− isEffDict _ _ = False

102 -- Remove __do function applications which remain after desugaring

71 -- Remove __do function applications which remain after desugaring

103 undo :: JS -> JS

72 undo :: JS -> JS

104 undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body

73 undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body

src/Language/PureScript/Constants.hs+101−23

@@ -1,18 +1,6 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Constants

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11-- |

1-- |

12-- Various constants which refer to things in the Prelude

2-- Various constants which refer to things in the Prelude

13--

3--

14−-----------------------------------------------------------------------------

15−

16module Language.PureScript.Constants where

4module Language.PureScript.Constants where

18-- Operators

6-- Operators

@@ -20,59 +8,107 @@ module Language.PureScript.Constants where

20($) :: String

8($) :: String

21($) = "$"

9($) = "$"

11+apply :: String

12+apply = "apply"

13+

23(#) :: String

14(#) :: String

24(#) = "#"

15(#) = "#"

17+applyFlipped :: String

18+applyFlipped = "applyFlipped"

19+

26(<>) :: String

20(<>) :: String

27(<>) = "<>"

21(<>) = "<>"

29(++) :: String

23(++) :: String

30(++) = "++"

24(++) = "++"

26+append :: String

27+append = "append"

28+

32(>>=) :: String

29(>>=) :: String

33(>>=) = ">>="

30(>>=) = ">>="

32+bind :: String

33+bind = "bind"

34+

35(+) :: String

36(+) = "+"

38+add :: String

39+add = "add"

40+

38(-) :: String

41(-) :: String

39(-) = "-"

42(-) = "-"

44+sub :: String

45+sub = "sub"

46+

41(*) :: String

47(*) :: String

42(*) = "*"

48(*) = "*"

50+mul :: String

51+mul = "mul"

52+

44(/) :: String

53(/) :: String

45(/) = "/"

54(/) = "/"

56+div :: String

57+div = "div"

58+

47(%) :: String

59(%) :: String

48(%) = "%"

60(%) = "%"

62+mod :: String

63+mod = "mod"

64+

50(<) :: String

65(<) :: String

51(<) = "<"

66(<) = "<"

68+lessThan :: String

69+lessThan = "lessThan"

70+

53(>) :: String

71(>) :: String

54(>) = ">"

72(>) = ">"

74+greaterThan :: String

75+greaterThan = "greaterThan"

76+

56(<=) :: String

77(<=) :: String

57(<=) = "<="

78(<=) = "<="

80+lessThanOrEq :: String

81+lessThanOrEq = "lessThanOrEq"

82+

59(>=) :: String

83(>=) :: String

60(>=) = ">="

84(>=) = ">="

86+greaterThanOrEq :: String

87+greaterThanOrEq = "greaterThanOrEq"

88+

62(==) :: String

89(==) :: String

63(==) = "=="

90(==) = "=="

92+eq :: String

93+eq = "eq"

94+

65(/=) :: String

95(/=) :: String

66(/=) = "/="

96(/=) = "/="

98+notEq :: String

99+notEq = "notEq"

100+

68(&&) :: String

101(&&) :: String

69(&&) = "&&"

102(&&) = "&&"

103

104+conj :: String

105+conj = "conj"

106+

71(||) :: String

107(||) :: String

72(||) = "||"

108(||) = "||"

109

74−bind :: String

110+disj :: String

75−bind = "bind"

111+disj = "disj"

112

77unsafeIndex :: String

113unsafeIndex :: String

78unsafeIndex = "unsafeIndex"

114unsafeIndex = "unsafeIndex"

@@ -92,6 +128,12 @@ unsafeIndex = "unsafeIndex"

92compose :: String

128compose :: String

93compose = "compose"

129compose = "compose"

130

131+(>>>) :: String

132+(>>>) = ">>>"

133+

134+composeFlipped :: String

135+composeFlipped = "composeFlipped"

136+

95-- Functions

137-- Functions

138

97negate :: String

139negate :: String

@@ -100,15 +142,6 @@ negate = "negate"

100not :: String

142not :: String

101not = "not"

143not = "not"

102

144

103−conj :: String

104−conj = "conj"

105−

106−disj :: String

107−disj = "disj"

108−

109−mod :: String

110−mod = "mod"

111−

112shl :: String

145shl :: String

113shl = "shl"

146shl = "shl"

114

147

@@ -211,12 +244,21 @@ moduloSemiringNumber = "moduloSemiringNumber"

211moduloSemiringInt :: String

244moduloSemiringInt :: String

212moduloSemiringInt = "moduloSemiringInt"

245moduloSemiringInt = "moduloSemiringInt"

213

246

247+ordBoolean :: String

248+ordBoolean = "ordBoolean"

249+

214ordNumber :: String

250ordNumber :: String

215ordNumber = "ordNumber"

251ordNumber = "ordNumber"

216

252

217ordInt :: String

253ordInt :: String

218ordInt = "ordInt"

254ordInt = "ordInt"

219

255

256+ordString :: String

257+ordString = "ordString"

258+

259+ordChar :: String

260+ordChar = "ordChar"

261+

220eqNumber :: String

262eqNumber :: String

221eqNumber = "eqNumber"

263eqNumber = "eqNumber"

222

264

@@ -226,6 +268,9 @@ eqInt = "eqInt"

226eqString :: String

268eqString :: String

227eqString = "eqString"

269eqString = "eqString"

228

270

271+eqChar :: String

272+eqChar = "eqChar"

273+

229eqBoolean :: String

274eqBoolean :: String

230eqBoolean = "eqBoolean"

275eqBoolean = "eqBoolean"

231

276

@@ -285,6 +330,39 @@ eff = "Control_Monad_Eff"

285st :: String

330st :: String

286st = "Control_Monad_ST"

331st = "Control_Monad_ST"

287

332

333+controlApplicative :: String

334+controlApplicative = "Control_Applicative"

335+

336+controlSemigroupoid :: String

337+controlSemigroupoid = "Control_Semigroupoid"

338+

339+controlBind :: String

340+controlBind = "Control_Bind"

341+

342+dataBounded :: String

343+dataBounded = "Data_Bounded"

344+

345+dataSemigroup :: String

346+dataSemigroup = "Data_Semigroup"

347+

348+dataModuloSemiring :: String

349+dataModuloSemiring = "Data_ModuloSemiring"

350+

351+dataBooleanAlgebra :: String

352+dataBooleanAlgebra = "Data_BooleanAlgebra"

353+

354+dataEq :: String

355+dataEq = "Data_Eq"

356+

357+dataOrd :: String

358+dataOrd = "Data_Ord"

359+

360+dataSemiring :: String

361+dataSemiring = "Data_Semiring"

362+

363+dataRing :: String

364+dataRing = "Data_Ring"

365+

288dataFunction :: String

366dataFunction :: String

289dataFunction = "Data_Function"

367dataFunction = "Data_Function"

290

368

src/Language/PureScript/CoreFn/Traversals.hs+1

@@ -40,6 +40,7 @@ everywhereOnValues f g h = (f', g', h')

41 h' (LiteralBinder a b) = h (LiteralBinder a (handleLiteral h' b))

42 h' (NamedBinder a name b) = h (NamedBinder a name (h' b))

43+ h' (ConstructorBinder a q1 q2 bs) = h (ConstructorBinder a q1 q2 (map h' bs))

43 h' b = h b

44 h' b = h b

45 handleCaseAlternative ca =

46 handleCaseAlternative ca =

src/Language/PureScript/Docs/Convert/ReExports.hs+78−36

@@ -13,6 +13,8 @@ import Prelude.Compat

13import Control.Monad

14import Control.Monad.Trans.State.Strict (execState)

15import Control.Monad.State.Class (MonadState, gets, modify)

16+import Control.Monad.Trans.Reader (runReaderT)

17+import Control.Monad.Reader.Class (MonadReader, ask)

16import Control.Arrow ((&&&), first, second)

18import Control.Arrow ((&&&), first, second)

17import Data.Either

19import Data.Either

18import Data.Maybe (mapMaybe)

20import Data.Maybe (mapMaybe)

@@ -76,9 +78,12 @@ getReExports env mn =

76 case Map.lookup mn env of

78 case Map.lookup mn env of

77 Nothing ->

79 Nothing ->

78 internalError ("Module missing: " ++ P.runModuleName mn)

80 internalError ("Module missing: " ++ P.runModuleName mn)

79− Just (_, imports, exports) ->

81+ Just (_, imports, exports) -> do

82+ allExports <- runReaderT (collectDeclarations imports exports) mn

83+ pure (filter notLocal allExports)

84+

85+ where

80− let notLocal = (/= mn) . fst

86+ notLocal = (/= mn) . fst

81− in filter notLocal <$> collectDeclarations imports exports

83-- |

88-- |

84-- Assemble a list of declarations re-exported from a particular module, based

89-- Assemble a list of declarations re-exported from a particular module, based

@@ -100,7 +105,9 @@ getReExports env mn =

100-- class members are listed.

105-- class members are listed.

101--

106--

102collectDeclarations ::

107collectDeclarations ::

108+ (Functor m, Applicative m,

103− (Functor m, Applicative m, MonadState (Map P.ModuleName Module) m) =>

109+ MonadState (Map P.ModuleName Module) m,

110+ MonadReader P.ModuleName m) =>

104 P.Imports ->

111 P.Imports ->

105 P.Exports ->

112 P.Exports ->

106 m [(P.ModuleName, [Declaration])]

113 m [(P.ModuleName, [Declaration])]

@@ -109,7 +116,7 @@ collectDeclarations imports exports = do

109 typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs

116 typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs

110 types <- collect lookupTypeDeclaration impTypes expTypes

117 types <- collect lookupTypeDeclaration impTypes expTypes

111

118

112− let (vals, classes) = handleTypeClassMembers valsAndMembers typeClasses

119+ (vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses

113

120

114 let filteredTypes = filterDataConstructors expCtors types

121 let filteredTypes = filterDataConstructors expCtors types

115 let filteredClasses = filterTypeClassMembers (map fst expVals) classes

122 let filteredClasses = filterTypeClassMembers (map fst expVals) classes

@@ -117,9 +124,9 @@ collectDeclarations imports exports = do

117 pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals]))

124 pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals]))

118

125

119 where

126 where

120− collect lookup' imps exps =

127+ collect lookup' imps exps = do

128+ imps' <- traverse (findImport imps) exps

121− Map.fromListWith (<>) <$> traverse (uncurry lookup')

129+ Map.fromListWith (<>) <$> traverse (uncurry lookup') imps'

122− (map (findImport imps) exps)

123

130

124 expVals = P.exportedValues exports

131 expVals = P.exportedValues exports

125 impVals = concat (Map.elems (P.importedValues imports))

132 impVals = concat (Map.elems (P.importedValues imports))

@@ -147,19 +154,29 @@ collectDeclarations imports exports = do

147-- instantiate @name@ as both 'P.Ident' and 'P.ProperName'.

154-- instantiate @name@ as both 'P.Ident' and 'P.ProperName'.

148--

155--

149findImport ::

156findImport ::

150− (Show name, Eq name) =>

157+ (Show name, Eq name, Applicative m, MonadReader P.ModuleName m) =>

151 [(P.Qualified name, P.ModuleName)] ->

158 [(P.Qualified name, P.ModuleName)] ->

152 (name, P.ModuleName) ->

159 (name, P.ModuleName) ->

153− (P.ModuleName, name)

160+ m (P.ModuleName, name)

154findImport imps (name, orig) =

161findImport imps (name, orig) =

162+ let

155− case filter (\(qual, mn) -> P.disqualify qual == name && mn == orig) imps of

163+ matches (qual, mn) = P.disqualify qual == name && mn == orig

156− [(P.Qualified (Just importedFrom) _, _)] ->

164+ matching = filter matches imps

157− (importedFrom, name)

165+ getQualified (P.Qualified mname _) = mname

158− other ->

166+ in

159− internalError ("findImport: unexpected result: " ++ show other)

167+ case mapMaybe (getQualified . fst) matching of

168+ -- A value can occur more than once if it is imported twice (eg, if it is

169+ -- exported by A, re-exported from A by B, and C imports it from both A

170+ -- and B). In this case, we just take its first appearance.

171+ (importedFrom:_) ->

172+ pure (importedFrom, name)

173+ [] ->

174+ internalErrorInModule ("findImport: not found: " ++ show (name, orig))

160

175

161lookupValueDeclaration ::

176lookupValueDeclaration ::

177+ (Applicative m,

162− (MonadState (Map P.ModuleName Module) m, Applicative m) =>

178+ MonadState (Map P.ModuleName Module) m,

179+ MonadReader P.ModuleName m) =>

163 P.ModuleName ->

180 P.ModuleName ->

164 P.Ident ->

181 P.Ident ->

165 m (P.ModuleName, [Either (String, P.Constraint, ChildDeclaration) Declaration])

182 m (P.ModuleName, [Either (String, P.Constraint, ChildDeclaration) Declaration])

@@ -170,7 +187,7 @@ lookupValueDeclaration importedFrom ident = do

170 filter (\d -> declTitle d == P.showIdent ident

187 filter (\d -> declTitle d == P.showIdent ident

171 && (isValue d || isAlias d)) decls

188 && (isValue d || isAlias d)) decls

172 errOther other =

189 errOther other =

173− internalError

190+ internalErrorInModule

174 ("lookupValueDeclaration: unexpected result:\n" ++

191 ("lookupValueDeclaration: unexpected result:\n" ++

175 "other: " ++ show other ++ "\n" ++

192 "other: " ++ show other ++ "\n" ++

176 "ident: " ++ show ident ++ "\n" ++

193 "ident: " ++ show ident ++ "\n" ++

@@ -216,7 +233,9 @@ lookupValueDeclaration importedFrom ident = do

216-- are only included in the output if they are listed in the arguments.

233-- are only included in the output if they are listed in the arguments.

217--

234--

218lookupTypeDeclaration ::

235lookupTypeDeclaration ::

236+ (Applicative m,

219− (MonadState (Map P.ModuleName Module) m, Applicative m) =>

237+ MonadState (Map P.ModuleName Module) m,

238+ MonadReader P.ModuleName m) =>

220 P.ModuleName ->

239 P.ModuleName ->

221 P.ProperName 'P.TypeName ->

240 P.ProperName 'P.TypeName ->

222 m (P.ModuleName, [Declaration])

241 m (P.ModuleName, [Declaration])

@@ -228,11 +247,13 @@ lookupTypeDeclaration importedFrom ty = do

228 [d] ->

247 [d] ->

229 pure (importedFrom, [d])

248 pure (importedFrom, [d])

230 other ->

249 other ->

231− internalError

250+ internalErrorInModule

232 ("lookupTypeDeclaration: unexpected result: " ++ show other)

251 ("lookupTypeDeclaration: unexpected result: " ++ show other)

233

252

234lookupTypeClassDeclaration ::

253lookupTypeClassDeclaration ::

254+ (Applicative m,

235− (MonadState (Map P.ModuleName Module) m, Applicative m) =>

255+ MonadState (Map P.ModuleName Module) m,

256+ MonadReader P.ModuleName m) =>

236 P.ModuleName ->

257 P.ModuleName ->

237 P.ProperName 'P.ClassName ->

258 P.ProperName 'P.ClassName ->

238 m (P.ModuleName, [Declaration])

259 m (P.ModuleName, [Declaration])

@@ -246,15 +267,18 @@ lookupTypeClassDeclaration importedFrom tyClass = do

246 [d] ->

267 [d] ->

247 pure (importedFrom, [d])

268 pure (importedFrom, [d])

248 other ->

269 other ->

270+ internalErrorInModule

249− internalError ("lookupTypeClassDeclaration: unexpected result: "

271+ ("lookupTypeClassDeclaration: unexpected result: "

250− ++ (unlines . map show) other)

272+ ++ (unlines . map show) other)

251

273

252-- |

274-- |

253-- Get the full list of declarations for a particular module out of the

275-- Get the full list of declarations for a particular module out of the

254-- state, or raise an internal error if it is not there.

276-- state, or raise an internal error if it is not there.

255--

277--

256lookupModuleDeclarations ::

278lookupModuleDeclarations ::

279+ (Applicative m,

257− (Applicative m, MonadState (Map P.ModuleName Module) m) =>

280+ MonadState (Map P.ModuleName Module) m,

281+ MonadReader P.ModuleName m) =>

258 String ->

282 String ->

259 P.ModuleName ->

283 P.ModuleName ->

260 m [Declaration]

284 m [Declaration]

@@ -262,15 +286,18 @@ lookupModuleDeclarations definedIn moduleName = do

262 mmdl <- gets (Map.lookup moduleName)

286 mmdl <- gets (Map.lookup moduleName)

263 case mmdl of

287 case mmdl of

264 Nothing ->

288 Nothing ->

289+ internalErrorInModule

265− internalError (definedIn ++ ": module missing: "

290+ (definedIn ++ ": module missing: "

266− ++ P.runModuleName moduleName)

291+ ++ P.runModuleName moduleName)

267 Just mdl ->

292 Just mdl ->

268 pure (allDeclarations mdl)

293 pure (allDeclarations mdl)

269

294

270handleTypeClassMembers ::

295handleTypeClassMembers ::

296+ (Functor m, Applicative m,

297+ MonadReader P.ModuleName m) =>

271 Map P.ModuleName [Either (String, P.Constraint, ChildDeclaration) Declaration] ->

298 Map P.ModuleName [Either (String, P.Constraint, ChildDeclaration) Declaration] ->

272 Map P.ModuleName [Declaration] ->

299 Map P.ModuleName [Declaration] ->

273− (Map P.ModuleName [Declaration], Map P.ModuleName [Declaration])

300+ m (Map P.ModuleName [Declaration], Map P.ModuleName [Declaration])

274handleTypeClassMembers valsAndMembers typeClasses =

301handleTypeClassMembers valsAndMembers typeClasses =

275 let

302 let

276 moduleEnvs =

303 moduleEnvs =

@@ -279,8 +306,8 @@ handleTypeClassMembers valsAndMembers typeClasses =

279 (fmap typeClassesToEnv typeClasses)

306 (fmap typeClassesToEnv typeClasses)

280 in

307 in

281 moduleEnvs

308 moduleEnvs

282− |> fmap handleEnv

309+ |> traverse handleEnv

283− |> splitMap

310+ |> fmap splitMap

284

311

285valsAndMembersToEnv ::

312valsAndMembersToEnv ::

286 [Either (String, P.Constraint, ChildDeclaration) Declaration] -> TypeClassEnv

313 [Either (String, P.Constraint, ChildDeclaration) Declaration] -> TypeClassEnv

@@ -336,11 +363,15 @@ instance Monoid TypeClassEnv where

336--

363--

337-- Returns a tuple of (values, type classes).

364-- Returns a tuple of (values, type classes).

338--

365--

366+handleEnv ::

367+ (Functor m, Applicative m,

368+ MonadReader P.ModuleName m) =>

369+ TypeClassEnv ->

339−handleEnv :: TypeClassEnv -> ([Declaration], [Declaration])

370+ m ([Declaration], [Declaration])

340handleEnv TypeClassEnv{..} =

371handleEnv TypeClassEnv{..} =

341 envUnhandledMembers

372 envUnhandledMembers

342− |> foldl go (envValues, mkMap envTypeClasses)

373+ |> foldM go (envValues, mkMap envTypeClasses)

343− |> second Map.elems

374+ |> fmap (second Map.elems)

344

375

345 where

376 where

346 mkMap =

377 mkMap =

@@ -351,14 +382,15 @@ handleEnv TypeClassEnv{..} =

351 Just _ ->

382 Just _ ->

352 -- Leave the state unchanged; if the type class is there, the child

383 -- Leave the state unchanged; if the type class is there, the child

353 -- will be too.

384 -- will be too.

354− (values, tcs)

385+ pure (values, tcs)

355− Nothing ->

386+ Nothing -> do

356− (promoteChild constraint childDecl : values, tcs)

387+ c <- promoteChild constraint childDecl

388+ pure (c : values, tcs)

357

389

358 promoteChild constraint ChildDeclaration{..} =

390 promoteChild constraint ChildDeclaration{..} =

359 case cdeclInfo of

391 case cdeclInfo of

360 ChildTypeClassMember typ ->

392 ChildTypeClassMember typ ->

361− Declaration

393+ pure $ Declaration

362 { declTitle = cdeclTitle

394 { declTitle = cdeclTitle

363 , declComments = cdeclComments

395 , declComments = cdeclComments

364 , declSourceSpan = cdeclSourceSpan

396 , declSourceSpan = cdeclSourceSpan

@@ -367,7 +399,7 @@ handleEnv TypeClassEnv{..} =

367 , declInfo = ValueDeclaration (addConstraint constraint typ)

399 , declInfo = ValueDeclaration (addConstraint constraint typ)

368 }

400 }

369 _ ->

401 _ ->

370− internalError

402+ internalErrorInModule

371 ("handleEnv: Bad child declaration passed to promoteChild: "

403 ("handleEnv: Bad child declaration passed to promoteChild: "

372 ++ cdeclTitle)

404 ++ cdeclTitle)

373

405

@@ -429,6 +461,16 @@ x |> f = f x

429internalError :: String -> a

461internalError :: String -> a

430internalError = P.internalError . ("Docs.Convert.ReExports: " ++)

462internalError = P.internalError . ("Docs.Convert.ReExports: " ++)

431

463

464+internalErrorInModule ::

465+ (MonadReader P.ModuleName m) =>

466+ String ->

467+ m a

468+internalErrorInModule msg = do

469+ mn <- ask

470+ internalError

471+ ("while collecting re-exports for module: " ++ P.runModuleName mn ++

472+ ", " ++ msg)

473+

432-- |

474-- |

433-- If the provided Declaration is a TypeClassDeclaration, construct an

475-- If the provided Declaration is a TypeClassDeclaration, construct an

434-- appropriate Constraint for use with the types of its members.

476-- appropriate Constraint for use with the types of its members.

src/Language/PureScript/Linter/Exhaustive.hs+1

@@ -203,6 +203,7 @@ isExhaustiveGuard (Left gs) = not . null $ filter (\(g, _) -> isOtherwise g) gs

203 isOtherwise :: Expr -> Bool

204 isOtherwise (TypedValue _ (BooleanLiteral True) _) = True

205 isOtherwise (TypedValue _ (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) _) = True

206+ isOtherwise (TypedValue _ (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) _) = True

206 isOtherwise _ = False

207 isOtherwise _ = False

207isExhaustiveGuard (Right _) = True

208isExhaustiveGuard (Right _) = True

208

209

src/Language/PureScript/ModuleDependencies.hs+6−4

@@ -23,7 +23,7 @@ import Control.Monad.Error.Class (MonadError(..))

24import Data.Graph

25import Data.List (nub)

26−import Data.Maybe (fromMaybe, mapMaybe)

26+import Data.Maybe (fromMaybe)

28import Language.PureScript.Crash

29import Language.PureScript.AST

@@ -54,22 +54,24 @@ sortModules ms = do

54-- Calculate a list of used modules based on explicit imports and qualified names

55--

56usedModules :: Declaration -> [ModuleName]

57+usedModules d =

57−usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const []) in nub . f

58+ let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const [])

59+ (g, _, _, _, _) = accumTypes (everythingOnTypes (++) forTypes)

60+ in nub (f d ++ g d)

58 where

61 where

59 forDecls :: Declaration -> [ModuleName]

62 forDecls :: Declaration -> [ModuleName]

60 forDecls (ImportDeclaration mn _ _ _) = [mn]

63 forDecls (ImportDeclaration mn _ _ _) = [mn]

61 forDecls (FixityDeclaration _ _ (Just (Qualified (Just mn) _))) = [mn]

64 forDecls (FixityDeclaration _ _ (Just (Qualified (Just mn) _))) = [mn]

65+ forDecls (TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) = [mn]

62 forDecls _ = []

66 forDecls _ = []

64 forValues :: Expr -> [ModuleName]

68 forValues :: Expr -> [ModuleName]

65 forValues (Var (Qualified (Just mn) _)) = [mn]

69 forValues (Var (Qualified (Just mn) _)) = [mn]

66 forValues (Constructor (Qualified (Just mn) _)) = [mn]

70 forValues (Constructor (Qualified (Just mn) _)) = [mn]

67− forValues (TypedValue _ _ ty) = forTypes ty

68 forValues _ = []

71 forValues _ = []

70 forTypes :: Type -> [ModuleName]

73 forTypes :: Type -> [ModuleName]

71 forTypes (TypeConstructor (Qualified (Just mn) _)) = [mn]

74 forTypes (TypeConstructor (Qualified (Just mn) _)) = [mn]

72− forTypes (ConstrainedType cs _) = mapMaybe (\(Qualified mn _, _) -> mn) cs

73 forTypes _ = []

75 forTypes _ = []

75-- |

77-- |

src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+8−5

@@ -17,6 +17,7 @@ import Data.List (foldl', find, sortBy)

17import Data.Maybe (fromMaybe)

18import Data.Ord (comparing)

20+import Control.Arrow (second)

20import Control.Monad (replicateM)

21import Control.Monad (replicateM)

21import Control.Monad.Supply.Class (MonadSupply)

22import Control.Monad.Supply.Class (MonadSupply)

22import Control.Monad.Error.Class (MonadError(..))

23import Control.Monad.Error.Class (MonadError(..))

@@ -55,11 +56,13 @@ deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration p

55deriveInstance _ _ e = return e

56deriveInstance _ _ e = return e

57unwrapTypeConstructor :: Type -> Maybe (Qualified (ProperName 'TypeName), [Type])

58unwrapTypeConstructor :: Type -> Maybe (Qualified (ProperName 'TypeName), [Type])

59+unwrapTypeConstructor = fmap (second reverse) . go

60+ where

58−unwrapTypeConstructor (TypeConstructor tyCon) = Just (tyCon, [])

61+ go (TypeConstructor tyCon) = Just (tyCon, [])

59−unwrapTypeConstructor (TypeApp ty arg) = do

62+ go (TypeApp ty arg) = do

60− (tyCon, args) <- unwrapTypeConstructor ty

63+ (tyCon, args) <- go ty

61− return (tyCon, arg : args)

64+ return (tyCon, arg : args)

62−unwrapTypeConstructor _ = Nothing

65+ go _ = Nothing

64dataGeneric :: ModuleName

67dataGeneric :: ModuleName

65dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]

68dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]