550fabe · rowtype-yoga/purescript-native

.gitmodulesnew file+3

compare with golang

unifiedsplit

@@ -0,0 +1,3 @@

1+[submodule "tests/support/prelude"]

2+ path = tests/support/prelude

3+ url = https://github.com/purescript/purescript-prelude

examples/failing/OperatorAliasNoExport.pursnew file+7

@@ -0,0 +1,7 @@

1+-- @shouldFailWith TransitiveExportError

2+module Test ((?!)) where

3+

4+infixl 4 what as ?!

5+

6+what :: forall a b. a -> b -> a

7+what a _ = a

examples/passing/OperatorAlias.pursnew file+11

@@ -0,0 +1,11 @@

1+module Main where

2+

3+import Prelude

4+import Control.Monad.Eff.Console

5+

6+infixl 4 what as ?!

7+

8+what :: forall a b. a -> b -> a

9+what a _ = a

10+

11+main = log $ "Done" ?! true

purescript.cabal+4−2

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

1name: purescript

2−version: 0.7.6.1

2+version: 0.8.0.0

3cabal-version: >=1.8

4build-type: Simple

5license: MIT

@@ -261,10 +261,12 @@ test-suite tests

261 build-depends: base >=4 && <5, containers -any, directory -any,

262 filepath -any, mtl -any, parsec -any, purescript -any,

263 transformers -any, process -any, transformers-compat -any, time -any,

264+ Glob -any, aeson-better-errors -any, bytestring -any, aeson -any,

264− Glob -any, base-compat >=0.6.0

265+ base-compat -any

265 type: exitcode-stdio-1.0

266 type: exitcode-stdio-1.0

266 main-is: Main.hs

267 main-is: Main.hs

267 other-modules: TestsSetup

268 other-modules: TestsSetup

269+ TestPscPublish

268 buildable: True

270 buildable: True

269 hs-source-dirs: tests tests/common

271 hs-source-dirs: tests tests/common

270

272

src/Language/PureScript/AST/Declarations.hs+2−2

@@ -186,9 +186,9 @@ data Declaration

186 --

187 | ExternDataDeclaration ProperName Kind

188 -- |

189− -- A fixity declaration (fixity data, operator name)

189+ -- A fixity declaration (fixity data, operator name, value the operator is an alias for)

190 --

191− | FixityDeclaration Fixity String

191+ | FixityDeclaration Fixity String (Maybe Ident)

192 -- |

193 -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)

194 -- TODO: also a boolean specifying whether the old `qualified` syntax was used, so a warning can be raised in desugaring (remove for 0.9)

src/Language/PureScript/AST/Exported.hs+1−1

@@ -112,7 +112,7 @@ isExported (Just exps) decl = any (matches decl) exps

112 matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident'

113 matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident'

114 matches (ExternDeclaration ident _) (ValueRef ident') = ident == ident'

115− matches (FixityDeclaration _ name) (ValueRef ident') = name == runIdent ident'

115+ matches (FixityDeclaration _ name _) (ValueRef ident') = name == runIdent ident'

116 matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'

117 matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'

118 matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'

src/Language/PureScript/CoreFn/Desugar.hs+3−14

@@ -1,17 +1,3 @@

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

2−--

3−-- Module : Language.PureScript.CoreFn.Desugar

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | The AST -> CoreFn desugaring step

12−--

13−-----------------------------------------------------------------------------

14−

15module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where

1module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where

16

2

17import Data.Function (on)

3import Data.Function (on)

@@ -68,6 +54,9 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

68 declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds

54 declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds

69 declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) =

55 declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) =

70 [NonRec name (exprToCoreFn ss com Nothing e)]

56 [NonRec name (exprToCoreFn ss com Nothing e)]

57+ declToCoreFn ss com (A.FixityDeclaration _ name (Just alias)) =

58+ let qname = Qualified (Just mn) alias

59+ in [NonRec (Op name) (Var (ss, com, Nothing, getValueMeta qname) (Qualified Nothing alias))]

71 declToCoreFn ss _ (A.BindingGroupDeclaration ds) =

60 declToCoreFn ss _ (A.BindingGroupDeclaration ds) =

72 [Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds]

61 [Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds]

73 declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =

62 declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =

src/Language/PureScript/Docs/AsMarkdown.hs+5−3

@@ -45,7 +45,7 @@ declAsMarkdown decl@Declaration{..} = do

45 zipWithM_ (\f c -> tell' (childToString f c)) (First : repeat NotFirst) children

46 spacer

47

48− for_ declFixity (\fixity -> fixityAsMarkdown fixity >> spacer)

48+ for_ declFixity (\(fixity, alias) -> fixityAsMarkdown fixity alias >> spacer)

49

50 for_ declComments tell'

51

@@ -68,9 +68,11 @@ codeToString = outputWith elemAsMarkdown

68 elemAsMarkdown (Keyword x) = x

69 elemAsMarkdown Space = " "

70

71−fixityAsMarkdown :: P.Fixity -> Docs

71+fixityAsMarkdown :: P.Fixity -> Maybe String -> Docs

72−fixityAsMarkdown (P.Fixity associativity precedence) =

72+fixityAsMarkdown (P.Fixity associativity precedence) alias =

73+ -- TODO: link alias name to member

73 tell' $ concat [ "_"

74 tell' $ concat [ "_"

75+ , maybe "" (\i -> "alias for " ++ i ++ " - ") alias

74 , associativityStr

76 , associativityStr

75 , " / precedence "

77 , " / precedence "

76 , show precedence

78 , show precedence

src/Language/PureScript/Docs/Convert.hs+10−7

@@ -11,6 +11,9 @@ module Language.PureScript.Docs.Convert

11 , collectBookmarks

12 ) where

13

14+import Prelude ()

15+import Prelude.Compat

16+

14import Control.Monad

17import Control.Monad

15import Control.Category ((>>>))

18import Control.Category ((>>>))

16import Data.Either

19import Data.Either

@@ -68,7 +71,7 @@ type IntermediateDeclaration

68-- with their associativity and precedence.

71-- with their associativity and precedence.

69data DeclarationAugment

72data DeclarationAugment

70 = AugmentChild ChildDeclaration

73 = AugmentChild ChildDeclaration

71− | AugmentFixity P.Fixity

74+ | AugmentFixity P.Fixity (Maybe P.Ident)

72

75

73-- | Augment top-level declarations; the second pass. See the comments under

76-- | Augment top-level declarations; the second pass. See the comments under

74-- the type synonym IntermediateDeclaration for more information.

77-- the type synonym IntermediateDeclaration for more information.

@@ -86,8 +89,8 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) =

86 case a of

89 case a of

87 AugmentChild child ->

90 AugmentChild child ->

88 d { declChildren = declChildren d ++ [child] }

91 d { declChildren = declChildren d ++ [child] }

89− AugmentFixity fixity ->

92+ AugmentFixity fixity alias ->

90− d { declFixity = Just fixity }

93+ d { declFixity = Just (fixity, P.runIdent <$> alias) }

91

94

92-- | Add the default operator fixity for operators which do not have associated

95-- | Add the default operator fixity for operators which do not have associated

93-- fixity declarations.

96-- fixity declarations.

@@ -97,7 +100,7 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) =

97addDefaultFixity :: Declaration -> Declaration

100addDefaultFixity :: Declaration -> Declaration

98addDefaultFixity decl@Declaration{..}

101addDefaultFixity decl@Declaration{..}

99 | isOp declTitle && isNothing declFixity =

102 | isOp declTitle && isNothing declFixity =

100− decl { declFixity = Just defaultFixity }

103+ decl { declFixity = Just (defaultFixity, Nothing) }

101 | otherwise =

104 | otherwise =

102 decl

105 decl

103 where

106 where

@@ -113,7 +116,7 @@ getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProper

113getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name)

116getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name)

114getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (P.runProperName name)

117getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (P.runProperName name)

115getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)

118getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)

116−getDeclarationTitle (P.FixityDeclaration _ name) = Just ("(" ++ name ++ ")")

119+getDeclarationTitle (P.FixityDeclaration _ name _) = Just ("(" ++ name ++ ")")

117getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d

120getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d

118getDeclarationTitle _ = Nothing

121getDeclarationTitle _ = Nothing

119

122

@@ -170,8 +173,8 @@ convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) tit

170

173

171 childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)

174 childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)

172 classApp = foldl P.TypeApp (P.TypeConstructor className) tys

175 classApp = foldl P.TypeApp (P.TypeConstructor className) tys

173−convertDeclaration (P.FixityDeclaration fixity _) title =

176+convertDeclaration (P.FixityDeclaration fixity _ alias) title =

174− Just (Left ([title], AugmentFixity fixity))

177+ Just (Left ([title], AugmentFixity fixity alias))

175convertDeclaration (P.PositionedDeclaration srcSpan com d') title =

178convertDeclaration (P.PositionedDeclaration srcSpan com d') title =

176 fmap (addComments . addSourceSpan) (convertDeclaration d' title)

179 fmap (addComments . addSourceSpan) (convertDeclaration d' title)

177 where

180 where

src/Language/PureScript/Docs/Types.hs+7−4

@@ -84,7 +84,7 @@ data Declaration = Declaration

84 , declComments :: Maybe String

85 , declSourceSpan :: Maybe P.SourceSpan

86 , declChildren :: [ChildDeclaration]

87− , declFixity :: Maybe P.Fixity

87+ , declFixity :: Maybe (P.Fixity, Maybe String)

88 , declInfo :: DeclarationInfo

89 }

90 deriving (Show, Eq, Ord)

@@ -307,9 +307,12 @@ asDeclaration =

307 <*> key "fixity" (perhaps asFixity)

308 <*> key "info" asDeclarationInfo

309

310−asFixity :: Parse PackageError P.Fixity

310+asFixity :: Parse PackageError (P.Fixity, Maybe String)

311+asFixity = do

311−asFixity = P.Fixity <$> key "associativity" asAssociativity

312+ fixity <- P.Fixity <$> key "associativity" asAssociativity

312− <*> key "precedence" asIntegral

313+ <*> key "precedence" asIntegral

314+ alias <- keyMay "alias" asString

315+ return (fixity, alias)

313

316

314parseAssociativity :: String -> Maybe P.Associativity

317parseAssociativity :: String -> Maybe P.Associativity

315parseAssociativity str = case str of

318parseAssociativity str = case str of

src/Language/PureScript/Errors.hs+12−2

@@ -127,6 +127,7 @@ data SimpleErrorMessage

127 | UnusedExplicitImport ModuleName [String]

128 | UnusedDctorImport ProperName

129 | UnusedDctorExplicitImport ProperName [ProperName]

130+ | DeprecatedOperatorDecl String

130 | DeprecatedQualifiedSyntax ModuleName ModuleName

131 | DeprecatedQualifiedSyntax ModuleName ModuleName

131 | DeprecatedClassImport ModuleName ProperName

132 | DeprecatedClassImport ModuleName ProperName

132 | DeprecatedClassExport ProperName

133 | DeprecatedClassExport ProperName

@@ -271,6 +272,7 @@ errorCode em = case unwrapErrorMessage em of

271 UnusedExplicitImport{} -> "UnusedExplicitImport"

272 UnusedExplicitImport{} -> "UnusedExplicitImport"

272 UnusedDctorImport{} -> "UnusedDctorImport"

273 UnusedDctorImport{} -> "UnusedDctorImport"

273 UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"

274 UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"

275+ DeprecatedOperatorDecl{} -> "DeprecatedOperatorDecl"

274 DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax"

276 DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax"

275 DeprecatedClassImport{} -> "DeprecatedClassImport"

277 DeprecatedClassImport{} -> "DeprecatedClassImport"

276 DeprecatedClassExport{} -> "DeprecatedClassExport"

278 DeprecatedClassExport{} -> "DeprecatedClassExport"

@@ -712,8 +714,9 @@ prettyPrintSingleError full level e = do

712 , line "All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form."

714 , line "All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form."

713 ]

715 ]

714 renderSimpleErrorMessage (TransitiveExportError x ys) =

716 renderSimpleErrorMessage (TransitiveExportError x ys) =

715− paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")

717+ paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: "

716− : map (line . prettyPrintExport) ys

718+ , indent $ paras $ map (line . prettyPrintExport) ys

719+ ]

717 renderSimpleErrorMessage (ShadowedName nm) =

720 renderSimpleErrorMessage (ShadowedName nm) =

718 line $ "Name '" ++ showIdent nm ++ "' was shadowed."

721 line $ "Name '" ++ showIdent nm ++ "' was shadowed."

719 renderSimpleErrorMessage (ShadowedTypeVar tv) =

722 renderSimpleErrorMessage (ShadowedTypeVar tv) =

@@ -770,6 +773,13 @@ prettyPrintSingleError full level e = do

770 paras [ line $ "The import of type " ++ runProperName name ++ " includes the following unused data constructors:"

773 paras [ line $ "The import of type " ++ runProperName name ++ " includes the following unused data constructors:"

771 , indent $ paras $ map (line .runProperName) names ]

774 , indent $ paras $ map (line .runProperName) names ]

772

775

776+ renderSimpleErrorMessage (DeprecatedOperatorDecl name) =

777+ paras [ line $ "The operator (" ++ name ++ ") was declared as a value rather than an alias for a named function."

778+ , line "Operator aliases are declared by using a fixity declaration, for example:"

779+ , indent $ line $ "infixl 9 someFunction as " ++ name

780+ , line $ "Support for value-declared operators will be removed in PureScript 0.9."

781+ ]

782+

773 renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) =

783 renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) =

774 paras [ line $ "Import uses the deprecated 'qualified' syntax:"

784 paras [ line $ "Import uses the deprecated 'qualified' syntax:"

775 , indent $ line $ "import qualified " ++ runModuleName name ++ " as " ++ runModuleName qualName

785 , indent $ line $ "import qualified " ++ runModuleName name ++ " as " ++ runModuleName qualName

src/Language/PureScript/Externs.hs+6−16

@@ -1,22 +1,10 @@

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

2−--

3−-- Module : Language.PureScript.Externs

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations.

13−--

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

15−

16{-# LANGUAGE RecordWildCards #-}

1{-# LANGUAGE RecordWildCards #-}

17{-# LANGUAGE PatternGuards #-}

2{-# LANGUAGE PatternGuards #-}

18{-# LANGUAGE TemplateHaskell #-}

3{-# LANGUAGE TemplateHaskell #-}

19

4

5+-- |

6+-- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations.

7+--

20module Language.PureScript.Externs

8module Language.PureScript.Externs

21 ( ExternsFile(..)

9 ( ExternsFile(..)

22 , ExternsImport(..)

10 , ExternsImport(..)

@@ -84,6 +72,8 @@ data ExternsFixity = ExternsFixity

84 , efPrecedence :: Precedence

72 , efPrecedence :: Precedence

85 -- | The operator symbol

73 -- | The operator symbol

86 , efOperator :: String

74 , efOperator :: String

75+ -- | The value the operator is an alias for

76+ , efAlias :: Maybe Ident

87 } deriving (Show, Read)

77 } deriving (Show, Read)

88

78

89-- | A type or value declaration appearing in an externs file

79-- | A type or value declaration appearing in an externs file

@@ -163,7 +153,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

163 efDeclarations = concatMap toExternsDeclaration efExports

153 efDeclarations = concatMap toExternsDeclaration efExports

164

154

165 fixityDecl :: Declaration -> Maybe ExternsFixity

155 fixityDecl :: Declaration -> Maybe ExternsFixity

166− fixityDecl (FixityDeclaration (Fixity assoc prec) op) = fmap (const (ExternsFixity assoc prec op)) (find exportsOp exps)

156+ fixityDecl (FixityDeclaration (Fixity assoc prec) op alias) = fmap (const (ExternsFixity assoc prec op alias)) (find exportsOp exps)

167 where

157 where

168 exportsOp :: DeclarationRef -> Bool

158 exportsOp :: DeclarationRef -> Bool

169 exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r

159 exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r

src/Language/PureScript/Linter.hs+6−16

@@ -1,21 +1,10 @@

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

2−--

3−-- Module : Language.PureScript.Linter

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | This module implements a simple linting pass on the PureScript AST.

12−--

13−-----------------------------------------------------------------------------

14−

15{-# LANGUAGE FlexibleContexts #-}

1{-# LANGUAGE FlexibleContexts #-}

16{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

17{-# LANGUAGE PatternGuards #-}

3{-# LANGUAGE PatternGuards #-}

18

4

5+-- |

6+-- This module implements a simple linting pass on the PureScript AST.

7+--

19module Language.PureScript.Linter (lint, module L) where

8module Language.PureScript.Linter (lint, module L) where

20

9

21import Prelude ()

10import Prelude ()

@@ -66,11 +55,12 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl

66 f dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec

55 f dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec

67

56

68 stepD :: S.Set Ident -> Declaration -> MultipleErrors

57 stepD :: S.Set Ident -> Declaration -> MultipleErrors

58+ stepD _ (ValueDeclaration (Op name) _ _ _) = errorMessage (DeprecatedOperatorDecl name)

69− stepD _ (TypeClassDeclaration name _ _ decls) = foldMap go decls

59+ stepD _ (TypeClassDeclaration _ _ _ decls) = foldMap go decls

70 where

60 where

71 go :: Declaration -> MultipleErrors

61 go :: Declaration -> MultipleErrors

72 go (PositionedDeclaration _ _ d') = go d'

62 go (PositionedDeclaration _ _ d') = go d'

73− go (TypeDeclaration op@(Op _) _) = errorMessage (ClassOperator name op)

63+ go (TypeDeclaration (Op name) _) = errorMessage (DeprecatedOperatorDecl name)

74 go _ = mempty

64 go _ = mempty

75 stepD _ _ = mempty

65 stepD _ _ = mempty

76

66

src/Language/PureScript/Parser/Declarations.hs+2−1

@@ -125,8 +125,9 @@ parseFixityDeclaration :: TokenParser Declaration

125parseFixityDeclaration = do

126 fixity <- parseFixity

127 indented

128+ alias <- P.optionMaybe $ (Ident <$> identifier) <* reserved "as"

128 name <- symbol

129 name <- symbol

129− return $ FixityDeclaration fixity name

130+ return $ FixityDeclaration fixity name alias

130

131

131parseImportDeclaration :: TokenParser Declaration

132parseImportDeclaration :: TokenParser Declaration

132parseImportDeclaration = do

133parseImportDeclaration = do

src/Language/PureScript/Sugar/Names/Exports.hs+1

@@ -47,6 +47,7 @@ findExportable (Module _ _ mn ds _) =

47 updateExports exps (TypeSynonymDeclaration tn _ _) = exportType exps tn [] mn

48 updateExports exps (ExternDataDeclaration tn _) = exportType exps tn [] mn

49 updateExports exps (ValueDeclaration name _ _ _) = exportValue exps name mn

50+ updateExports exps (FixityDeclaration _ name (Just _)) = exportValue exps (Op name) mn

50 updateExports exps (ExternDeclaration name _) = exportValue exps name mn

51 updateExports exps (ExternDeclaration name _) = exportValue exps name mn

51 updateExports exps (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ updateExports exps d

52 updateExports exps (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ updateExports exps d

52 updateExports exps _ = return exps

53 updateExports exps _ = return exps

src/Language/PureScript/Sugar/Operators.hs+32−26

@@ -1,13 +1,8 @@

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

1+{-# LANGUAGE Rank2Types #-}

2−--

2+{-# LANGUAGE FlexibleContexts #-}

3−-- Module : Language.PureScript.Sugar.Operators

3+{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE RecordWildCards #-}

5−-- License : MIT (http://opensource.org/licenses/MIT)

5+

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11-- |

6-- |

12-- This module implements the desugaring pass which reapplies binary operators based

7-- This module implements the desugaring pass which reapplies binary operators based

13-- on their fixity data and removes explicit parentheses.

8-- on their fixity data and removes explicit parentheses.

@@ -15,13 +10,6 @@

15-- The value parser ignores fixity data when parsing binary operator applications, so

10-- The value parser ignores fixity data when parsing binary operator applications, so

16-- it is necessary to reorder them here.

11-- it is necessary to reorder them here.

17--

12--

18−-----------------------------------------------------------------------------

19−

20−{-# LANGUAGE Rank2Types #-}

21−{-# LANGUAGE FlexibleContexts #-}

22−{-# LANGUAGE ScopedTypeVariables #-}

23−{-# LANGUAGE RecordWildCards #-}

24−

25module Language.PureScript.Sugar.Operators (

13module Language.PureScript.Sugar.Operators (

26 rebracket,

14 rebracket,

27 removeSignedLiterals,

15 removeSignedLiterals,

@@ -44,6 +32,8 @@ import Control.Monad.Supply.Class

44import Data.Function (on)

32import Data.Function (on)

45import Data.Functor.Identity

33import Data.Functor.Identity

46import Data.List (groupBy, sortBy)

34import Data.List (groupBy, sortBy)

35+import Data.Maybe (mapMaybe, fromMaybe)

36+import qualified Data.Map as M

47

37

48import qualified Text.Parsec as P

38import qualified Text.Parsec as P

49import qualified Text.Parsec.Pos as P

39import qualified Text.Parsec.Pos as P

@@ -57,9 +47,24 @@ import qualified Language.PureScript.Constants as C

57rebracket :: (Applicative m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

47rebracket :: (Applicative m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

58rebracket externs ms = do

48rebracket externs ms = do

59 let fixities = concatMap externsFixities externs ++ concatMap collectFixities ms

49 let fixities = concatMap externsFixities externs ++ concatMap collectFixities ms

60− ensureNoDuplicates $ map (\(i, pos, _) -> (i, pos)) fixities

50+ ensureNoDuplicates $ map (\(i, pos, _, _) -> (i, pos)) fixities

61− let opTable = customOperatorTable $ map (\(i, _, f) -> (i, f)) fixities

51+ let opTable = customOperatorTable $ map (\(i, _, f, _) -> (i, f)) fixities

62− traverse (rebracketModule opTable) ms

52+ ms' <- traverse (rebracketModule opTable) ms

53+ let aliased = M.fromList (mapMaybe makeLookupEntry fixities)

54+ return $ renameAliasedOperators aliased `map` ms'

55+

56+ where

57+

58+ makeLookupEntry :: (Qualified Ident, SourceSpan, Fixity, Maybe Ident) -> Maybe (Qualified Ident, Qualified Ident)

59+ makeLookupEntry (qname@(Qualified qual _), _, _, Just alias) = Just (qname, Qualified qual alias)

60+ makeLookupEntry _ = Nothing

61+

62+ renameAliasedOperators :: M.Map (Qualified Ident) (Qualified Ident) -> Module -> Module

63+ renameAliasedOperators aliased (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts

64+ where

65+ (f', _, _) = everywhereOnValues id go id

66+ go (Var name) = Var $ fromMaybe name (name `M.lookup` aliased)

67+ go other = other

63

68

64removeSignedLiterals :: Module -> Module

69removeSignedLiterals :: Module -> Module

65removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts

70removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts

@@ -82,17 +87,18 @@ removeParens =

82 go (Parens val) = val

87 go (Parens val) = val

83 go val = val

88 go val = val

84

89

85−externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity)]

90+externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)]

86externsFixities ExternsFile{..} =

91externsFixities ExternsFile{..} =

87− [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec)

92+ [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec, alias)

88− | ExternsFixity assoc prec op <- efFixities

93+ | ExternsFixity assoc prec op alias <- efFixities

89 ]

94 ]

90

95

91−collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity)]

96+collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)]

92collectFixities (Module _ _ moduleName ds _) = concatMap collect ds

97collectFixities (Module _ _ moduleName ds _) = concatMap collect ds

93 where

98 where

94− collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity)]

99+ collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)]

95− collect (PositionedDeclaration pos _ (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]

100+ collect (PositionedDeclaration pos _ (FixityDeclaration fixity name alias)) =

101+ [(Qualified (Just moduleName) (Op name), pos, fixity, alias)]

96 collect FixityDeclaration{} = internalError "Fixity without srcpos info"

102 collect FixityDeclaration{} = internalError "Fixity without srcpos info"

97 collect _ = []

103 collect _ = []

98

104

src/Language/PureScript/TypeChecker.hs+27−21

@@ -1,22 +1,10 @@

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

2−--

3−-- Module : Language.PureScript.TypeChecker

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- The top-level type checker, which checks all declarations in a module.

13−--

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

15−

16{-# LANGUAGE ScopedTypeVariables #-}

1{-# LANGUAGE ScopedTypeVariables #-}

17{-# LANGUAGE FlexibleInstances #-}

2{-# LANGUAGE FlexibleInstances #-}

18{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

19

4

5+-- |

6+-- The top-level type checker, which checks all declarations in a module.

7+--

20module Language.PureScript.TypeChecker (

8module Language.PureScript.TypeChecker (

21 module T,

9 module T,

22 typeCheckModule

10 typeCheckModule

@@ -196,7 +184,7 @@ typeCheckAll :: forall m.

196 [DeclarationRef] ->

184 [DeclarationRef] ->

197 [Declaration] ->

185 [Declaration] ->

198 m [Declaration]

186 m [Declaration]

199−typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkOrphanFixities ds

187+typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

200 where

188 where

201 go :: Declaration -> m Declaration

189 go :: Declaration -> m Declaration

202 go (DataDeclaration dtype name args dctors) = do

190 go (DataDeclaration dtype name args dctors) = do

@@ -290,13 +278,16 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkOrphanFixities d

290 go (PositionedDeclaration pos com d) =

278 go (PositionedDeclaration pos com d) =

291 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d

279 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d

292

280

293− checkOrphanFixities :: Declaration -> m ()

281+ checkFixities :: Declaration -> m ()

294− checkOrphanFixities (FixityDeclaration _ name) = do

282+ checkFixities (FixityDeclaration _ name (Just alias)) = do

283+ ty <- lookupVariable moduleName (Qualified (Just moduleName) alias)

284+ addValue moduleName (Op name) ty Public

285+ checkFixities (FixityDeclaration _ name _) = do

295 env <- getEnv

286 env <- getEnv

296 guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env

287 guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env

297− checkOrphanFixities (PositionedDeclaration pos _ d) =

288+ checkFixities (PositionedDeclaration pos _ d) =

298− warnAndRethrowWithPosition pos $ checkOrphanFixities d

289+ warnAndRethrowWithPosition pos $ checkFixities d

299− checkOrphanFixities _ = return ()

290+ checkFixities _ = return ()

300

291

301 checkInstanceMembers :: [Declaration] -> m [Declaration]

292 checkInstanceMembers :: [Declaration] -> m [Declaration]

302 checkInstanceMembers instDecls = do

293 checkInstanceMembers instDecls = do

@@ -355,6 +346,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

355 checkTypesAreExported e

346 checkTypesAreExported e

356 checkClassMembersAreExported e

347 checkClassMembersAreExported e

357 checkClassesAreExported e

348 checkClassesAreExported e

349+ checkNonAliasesAreExported e

358 return $ Module ss coms mn decls' (Just exps)

350 return $ Module ss coms mn decls' (Just exps)

359 where

351 where

360

352

@@ -429,3 +421,17 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

429 extractMemberName (TypeDeclaration memberName _) = memberName

421 extractMemberName (TypeDeclaration memberName _) = memberName

430 extractMemberName _ = internalError "Unexpected declaration in typeclass member list"

422 extractMemberName _ = internalError "Unexpected declaration in typeclass member list"

431 checkClassMembersAreExported _ = return ()

423 checkClassMembersAreExported _ = return ()

424+

425+ checkNonAliasesAreExported :: DeclarationRef -> m ()

426+ checkNonAliasesAreExported dr@(ValueRef (Op name)) =

427+ case listToMaybe (mapMaybe getAlias decls) of

428+ Just alias ->

429+ when (not $ any (== ValueRef alias) exps) $

430+ throwError . errorMessage $ TransitiveExportError dr [ValueRef alias]

431+ _ -> return ()

432+ where

433+ getAlias :: Declaration -> Maybe Ident

434+ getAlias (PositionedDeclaration _ _ d) = getAlias d

435+ getAlias (FixityDeclaration _ name' alias) | name == name' = alias

436+ getAlias _ = Nothing

437+ checkNonAliasesAreExported _ = return ()

tests/Main.hs+10

@@ -68,6 +68,7 @@ import qualified System.FilePath.Glob as Glob

68import Text.Parsec (ParseError)

69

70import TestsSetup

71+import TestPscPublish

71

72

72modulesDir :: FilePath

73modulesDir :: FilePath

73modulesDir = ".test_modules" </> "node_modules"

74modulesDir = ".test_modules" </> "node_modules"

@@ -171,6 +172,11 @@ assertDoesNotCompile inputFiles foreigns = do

171

172

172main :: IO ()

173main :: IO ()

173main = do

174main = do

175+ testCompiler

176+ testPscPublish

177+

178+testCompiler :: IO ()

179+testCompiler = do

174 fetchSupportCode

180 fetchSupportCode

175 cwd <- getCurrentDirectory

181 cwd <- getCurrentDirectory

176

182

@@ -203,6 +209,10 @@ main = do

203 in putStrLn $ fp' ++ ": " ++ err

209 in putStrLn $ fp' ++ ": " ++ err

204 exitFailure

210 exitFailure

205

211

212+testPscPublish :: IO ()

213+testPscPublish = do

214+ testPackage "tests/support/prelude"

215+

206supportModules :: [String]

216supportModules :: [String]

207supportModules =

217supportModules =

208 [ "Control.Monad.Eff.Class"

218 [ "Control.Monad.Eff.Class"

psc-publish/tests/Test.hs → tests/TestPscPublish.hsrenamed+22−44

@@ -2,33 +2,24 @@

2{-# OPTIONS_GHC -fno-warn-unused-imports #-}

3{-# LANGUAGE ScopedTypeVariables #-}

4

5−-- | To run these tests:

6−--

7−-- * `cabal repl psc-publish`

8−-- * `:l psc-publish/tests/Test.hs`

9−-- * `test`

10−

11−module Test where

5+module TestPscPublish where

12

6

13import Control.Monad

7import Control.Monad

14import Control.Applicative

8import Control.Applicative

15import Control.Exception

9import Control.Exception

16import System.Process

10import System.Process

17import System.Directory

11import System.Directory

12+import System.IO

13+import System.Exit

18import qualified Data.ByteString.Lazy as BL

14import qualified Data.ByteString.Lazy as BL

19import Data.ByteString.Lazy (ByteString)

15import Data.ByteString.Lazy (ByteString)

20import qualified Data.Aeson as A

16import qualified Data.Aeson as A

21import Data.Aeson.BetterErrors

17import Data.Aeson.BetterErrors

22import Data.Version

18import Data.Version

23

19

24−import Main

25import Language.PureScript.Docs

20import Language.PureScript.Docs

26import Language.PureScript.Publish

21import Language.PureScript.Publish

27

22

28−pkgName = "purescript-prelude"

29−packageUrl = "https://github.com/purescript/" ++ pkgName

30−packageDir = "tmp/" ++ pkgName

31−

32pushd :: forall a. FilePath -> IO a -> IO a

23pushd :: forall a. FilePath -> IO a -> IO a

33pushd dir act = do

24pushd dir act = do

34 original <- getCurrentDirectory

25 original <- getCurrentDirectory

@@ -37,44 +28,12 @@ pushd dir act = do

37 setCurrentDirectory original

28 setCurrentDirectory original

38 either throwIO return result

29 either throwIO return result

39

30

40−clonePackage :: IO ()

41−clonePackage = do

42− createDirectoryIfMissing True packageDir

43− pushd packageDir $ do

44− exists <- doesDirectoryExist ".git"

45− unless exists $ do

46− putStrLn ("Cloning " ++ pkgName ++ " into " ++ packageDir ++ "...")

47− readProcess "git" ["clone", packageUrl, "."] "" >>= putStr

48− readProcess "git" ["tag", "v999.0.0"] "" >>= putStr

49−

50−bowerInstall :: IO ()

51−bowerInstall =

52− pushd packageDir $

53− readProcess "bower" ["install"] "" >>= putStr

54−

55−testRunOptions :: PublishOptions

56−testRunOptions = defaultPublishOptions

57− { publishGetVersion = return testVersion

58− }

59− where testVersion = ("v999.0.0", Version [999,0,0] [])

60−

61−getPackage :: IO UploadedPackage

62−getPackage = do

63− clonePackage

64− bowerInstall

65− pushd packageDir $ preparePackage testRunOptions

66−

67data TestResult

31data TestResult

68 = ParseFailed String

32 = ParseFailed String

69 | Mismatch ByteString ByteString -- ^ encoding before, encoding after

33 | Mismatch ByteString ByteString -- ^ encoding before, encoding after

70 | Pass ByteString

34 | Pass ByteString

71 deriving (Show, Read)

35 deriving (Show, Read)

72

36

73−-- | Test JSON encoding/decoding; parse the package, roundtrip to/from JSON,

74−-- and check we get the same string.

75−test :: IO TestResult

76−test = roundTrip <$> getPackage

77−

78roundTrip :: UploadedPackage -> TestResult

37roundTrip :: UploadedPackage -> TestResult

79roundTrip pkg =

38roundTrip pkg =

80 let before = A.encode pkg

39 let before = A.encode pkg

@@ -85,3 +44,22 @@ roundTrip pkg =

85 if before == after

44 if before == after

86 then Pass before

45 then Pass before

87 else Mismatch before after

46 else Mismatch before after

47+

48+testRunOptions :: PublishOptions

49+testRunOptions = defaultPublishOptions

50+ { publishGetVersion = return testVersion

51+ }

52+ where testVersion = ("v999.0.0", Version [999,0,0] [])

53+

54+-- | Given a directory which contains a package, produce JSON from it, and then

55+-- | attempt to parse it again, and ensure that it doesn't change.

56+testPackage :: String -> IO ()

57+testPackage dir = do

58+ pushd dir $ do

59+ r <- roundTrip <$> preparePackage testRunOptions

60+ case r of

61+ Pass _ -> pure ()

62+ other -> do

63+ hPutStrLn stderr ("psc-publish tests failed on " ++ dir ++ ":")

64+ hPutStrLn stderr (show other)

65+ exitFailure

tests/support/preludenew file+1

Submodule changed.