9a377c4 · rowtype-yoga/purescript-native

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

on golang help sign in

Operator aliases for data constructors

9a377c4Gary Burgess11 years ago

examples/failing/DctorOperatorAliasExport.pursnew file+6

compare with golang

unifiedsplit

@@ -0,0 +1,6 @@

1+-- @shouldFailWith TransitiveDctorExportError

2+module Data.List (List, (:)) where

4+ data List a = Cons a (List a) | Nil

6+ infixr 6 Cons as :

examples/failing/InvalidOperatorInBinder.pursnew file+12

@@ -0,0 +1,12 @@

1+-- @shouldFailWith InvalidOperatorInBinder

2+module Main where

4+data List a = Cons a (List a) | Nil

6+cons ∷ ∀ a. a → List a → List a

7+cons = Cons

9+infixl 6 cons as :

10+

11+get ∷ ∀ a. List a → a

12+get (_ : x : _) = x

examples/passing/DctorOperatorAlias.pursnew file+35

@@ -0,0 +1,35 @@

1+module Data.List where

3+ data List a = Cons a (List a) | Nil

5+ infixr 6 Cons as :

7+module Main where

9+ import Prelude (Unit, bind, (==))

10+ import Control.Monad.Eff (Eff)

11+ import Control.Monad.Eff.Console (CONSOLE, log)

12+ import Test.Assert (ASSERT, assert')

13+ import Data.List (List(..), (:))

14+

15+ infixl 6 Cons as !

16+

17+ get1 ∷ ∀ a. a → List a → a

18+ get1 y xs = case xs of

19+ _ : x : _ → x

20+ _ → y

21+

22+ get2 ∷ ∀ a. a → List a → a

23+ get2 _ (_ : x : _) = x

24+ get2 y _ = y

25+

26+ get3 ∷ ∀ a. a → List a → a

27+ get3 _ (_ ! (x ! _)) = x

28+ get3 y _ = y

29+

30+ main ∷ Eff (assert ∷ ASSERT, console ∷ CONSOLE) Unit

31+ main = do

32+ assert' "Incorrect result!" (get1 0 (1 : 2 : 3 : Nil) == 2)

33+ assert' "Incorrect result!" (get2 0 (1 ! (2 ! (3 ! Nil))) == 2)

34+ assert' "Incorrect result!" (get3 0.0 (1.0 : 2.0 : (3.0 ! Nil)) == 2.0)

35+ log "Done"

purescript.cabal+3

@@ -149,6 +149,9 @@ library

149 Language.PureScript.Sugar.Names.Exports

150 Language.PureScript.Sugar.ObjectWildcards

151 Language.PureScript.Sugar.Operators

152+ Language.PureScript.Sugar.Operators.Common

153+ Language.PureScript.Sugar.Operators.Expr

154+ Language.PureScript.Sugar.Operators.Binders

152 Language.PureScript.Sugar.TypeClasses

155 Language.PureScript.Sugar.TypeClasses

153 Language.PureScript.Sugar.TypeClasses.Deriving

156 Language.PureScript.Sugar.TypeClasses.Deriving

154 Language.PureScript.Sugar.TypeDeclarations

157 Language.PureScript.Sugar.TypeDeclarations

src/Language/PureScript/AST/Binders.hs+20

@@ -41,6 +41,24 @@ data Binder

41 --

42 | ConstructorBinder (Qualified (ProperName 'ConstructorName)) [Binder]

43 -- |

44+ -- A operator alias binder. During the rebracketing phase of desugaring,

45+ -- this data constructor will be removed.

46+ --

47+ | OpBinder (Qualified Ident)

48+ -- |

49+ -- Binary operator application. During the rebracketing phase of desugaring,

50+ -- this data constructor will be removed.

51+ --

52+ | BinaryNoParensBinder Binder Binder Binder

53+ -- |

54+ -- Explicit parentheses. During the rebracketing phase of desugaring, this

55+ -- data constructor will be removed.

56+ --

57+ -- Note: although it seems this constructor is not used, it _is_ useful,

58+ -- since it prevents certain traversals from matching.

59+ --

60+ | ParensInBinder Binder

61+ -- |

44 -- A binder which matches a record and binds its properties

62 -- A binder which matches a record and binds its properties

45 --

63 --

46 | ObjectBinder [(String, Binder)]

64 | ObjectBinder [(String, Binder)]

@@ -70,6 +88,8 @@ binderNames = go []

70 where

88 where

71 go ns (VarBinder name) = name : ns

89 go ns (VarBinder name) = name : ns

72 go ns (ConstructorBinder _ bs) = foldl go ns bs

90 go ns (ConstructorBinder _ bs) = foldl go ns bs

91+ go ns (BinaryNoParensBinder b1 b2 b3) = foldl go ns [b1, b2, b3]

92+ go ns (ParensInBinder b) = go ns b

73 go ns (ObjectBinder bs) = foldl go ns (map snd bs)

93 go ns (ObjectBinder bs) = foldl go ns (map snd bs)

74 go ns (ArrayBinder bs) = foldl go ns bs

94 go ns (ArrayBinder bs) = foldl go ns bs

75 go ns (NamedBinder name b) = go (name : ns) b

95 go ns (NamedBinder name b) = go (name : ns) b

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

@@ -189,7 +189,7 @@ data Declaration

189 -- |

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

191 --

192− | FixityDeclaration Fixity String (Maybe (Qualified Ident))

192+ | FixityDeclaration Fixity String (Maybe (Either (Qualified Ident) (Qualified (ProperName 'ConstructorName))))

193 -- |

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

195 -- 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/Traversals.hs+15−3

@@ -69,6 +69,8 @@ everywhereOnValues f g h = (f', g', h')

70 h' :: Binder -> Binder

71 h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs))

72+ h' (BinaryNoParensBinder b1 b2 b3) = h (BinaryNoParensBinder (h' b1) (h' b2) (h' b3))

73+ h' (ParensInBinder b) = h (ParensInBinder (h' b))

72 h' (ObjectBinder bs) = h (ObjectBinder (map (fmap h') bs))

74 h' (ObjectBinder bs) = h (ObjectBinder (map (fmap h') bs))

73 h' (ArrayBinder bs) = h (ArrayBinder (map h' bs))

75 h' (ArrayBinder bs) = h (ArrayBinder (map h' bs))

74 h' (NamedBinder name b) = h (NamedBinder name (h' b))

76 h' (NamedBinder name b) = h (NamedBinder name (h' b))

@@ -124,6 +126,8 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

124 g' other = g other

126 g' other = g other

125

127

126 h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h' <=< h) bs

128 h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h' <=< h) bs

129+ h' (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> (h b1 >>= h') <*> (h b2 >>= h') <*> (h b3 >>= h')

130+ h' (ParensInBinder b) = ParensInBinder <$> (h b >>= h')

127 h' (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h' <=< h)) bs

131 h' (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h' <=< h)) bs

128 h' (ArrayBinder bs) = ArrayBinder <$> traverse (h' <=< h) bs

132 h' (ArrayBinder bs) = ArrayBinder <$> traverse (h' <=< h) bs

129 h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')

133 h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')

@@ -175,6 +179,8 @@ everywhereOnValuesM f g h = (f', g', h')

175 g' other = g other

179 g' other = g other

176

180

177 h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> traverse h' bs) >>= h

181 h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> traverse h' bs) >>= h

182+ h' (BinaryNoParensBinder b1 b2 b3) = (BinaryNoParensBinder <$> h' b1 <*> h' b2 <*> h' b3) >>= h

183+ h' (ParensInBinder b) = (ParensInBinder <$> h' b) >>= h

178 h' (ObjectBinder bs) = (ObjectBinder <$> traverse (sndM h') bs) >>= h

184 h' (ObjectBinder bs) = (ObjectBinder <$> traverse (sndM h') bs) >>= h

179 h' (ArrayBinder bs) = (ArrayBinder <$> traverse h' bs) >>= h

185 h' (ArrayBinder bs) = (ArrayBinder <$> traverse h' bs) >>= h

180 h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h

186 h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h

@@ -229,6 +235,8 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')

229 g' v = g v

235 g' v = g v

230

236

231 h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs)

237 h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs)

238+ h' b@(BinaryNoParensBinder b1 b2 b3) = h b <> h' b1 <> h' b2 <> h' b3

239+ h' b@(ParensInBinder b1) = h b <> h' b1

232 h' b@(ObjectBinder bs) = foldl (<>) (h b) (map (h' . snd) bs)

240 h' b@(ObjectBinder bs) = foldl (<>) (h b) (map (h' . snd) bs)

233 h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs)

241 h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs)

234 h' b@(NamedBinder _ b1) = h b <> h' b1

242 h' b@(NamedBinder _ b1) = h b <> h' b1

@@ -296,6 +304,8 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'

296 h'' s b = let (s', r) = h s b in r <> h' s' b

304 h'' s b = let (s', r) = h s b in r <> h' s' b

297

305

298 h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs)

306 h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs)

307+ h' s (BinaryNoParensBinder b1 b2 b3) = h'' s b1 <> h'' s b2 <> h'' s b3

308+ h' s (ParensInBinder b) = h'' s b

299 h' s (ObjectBinder bs) = foldl (<>) r0 (map (h'' s . snd) bs)

309 h' s (ObjectBinder bs) = foldl (<>) r0 (map (h'' s . snd) bs)

300 h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs)

310 h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs)

301 h' s (NamedBinder _ b1) = h'' s b1

311 h' s (NamedBinder _ b1) = h'' s b1

@@ -364,6 +374,8 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

364 h'' s = uncurry h' <=< h s

374 h'' s = uncurry h' <=< h s

365

375

366 h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h'' s) bs

376 h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h'' s) bs

377+ h' s (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> h'' s b1 <*> h'' s b2 <*> h'' s b3

378+ h' s (ParensInBinder b) = ParensInBinder <$> h'' s b

367 h' s (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h'' s)) bs

379 h' s (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h'' s)) bs

368 h' s (ArrayBinder bs) = ArrayBinder <$> traverse (h'' s) bs

380 h' s (ArrayBinder bs) = ArrayBinder <$> traverse (h'' s) bs

369 h' s (NamedBinder name b) = NamedBinder name <$> h'' s b

381 h' s (NamedBinder name b) = NamedBinder name <$> h'' s b

@@ -451,11 +463,11 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)

451 h'' s a = h s a <> h' s a

463 h'' s a = h s a <> h' s a

452

464

453 h' s (ConstructorBinder _ bs) = foldMap (h'' s) bs

465 h' s (ConstructorBinder _ bs) = foldMap (h'' s) bs

466+ h' s (BinaryNoParensBinder b1 b2 b3) = foldMap (h'' s) [b1, b2, b3]

467+ h' s (ParensInBinder b) = h'' s b

454 h' s (ObjectBinder bs) = foldMap (h'' s . snd) bs

468 h' s (ObjectBinder bs) = foldMap (h'' s . snd) bs

455 h' s (ArrayBinder bs) = foldMap (h'' s) bs

469 h' s (ArrayBinder bs) = foldMap (h'' s) bs

456− h' s (NamedBinder name b1) =

470+ h' s (NamedBinder name b1) = h'' (S.insert name s) b1

457− let s' = S.insert name s

458− in h'' s' b1

459 h' s (PositionedBinder _ _ b1) = h'' s b1

471 h' s (PositionedBinder _ _ b1) = h'' s b1

460 h' s (TypedBinder _ b1) = h'' s b1

472 h' s (TypedBinder _ b1) = h'' s b1

461 h' _ _ = mempty

473 h' _ _ = mempty

src/Language/PureScript/CoreFn/Desugar.hs+18−6

@@ -55,7 +55,9 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

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

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

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

58+ let meta = either getValueMeta (Just . getConstructorMeta) alias

59+ alias' = either id (fmap properToIdent) alias

58− [NonRec (Op name) (Var (ss, com, Nothing, getValueMeta alias) alias)]

60+ in [NonRec (Op name) (Var (ss, com, Nothing, meta) alias')]

59 declToCoreFn ss _ (A.BindingGroupDeclaration ds) =

61 declToCoreFn ss _ (A.BindingGroupDeclaration ds) =

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

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

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

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

@@ -157,6 +159,12 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

157 binderToCoreFn (Just ss) (com ++ com1) b

159 binderToCoreFn (Just ss) (com ++ com1) b

158 binderToCoreFn ss com (A.TypedBinder _ b) =

160 binderToCoreFn ss com (A.TypedBinder _ b) =

159 binderToCoreFn ss com b

161 binderToCoreFn ss com b

162+ binderToCoreFn _ _ A.OpBinder{} =

163+ internalError "OpBinder should have been desugared before binderToCoreFn"

164+ binderToCoreFn _ _ A.BinaryNoParensBinder{} =

165+ internalError "BinaryNoParensBinder should have been desugared before binderToCoreFn"

166+ binderToCoreFn _ _ A.ParensInBinder{} =

167+ internalError "ParensInBinder should have been desugared before binderToCoreFn"

160

168

161 -- |

169 -- |

162 -- Gets metadata for values.

170 -- Gets metadata for values.

@@ -201,19 +209,23 @@ findQualModules decls =

201 in f `concatMap` decls

209 in f `concatMap` decls

202 where

210 where

203 fqDecls :: A.Declaration -> [ModuleName]

211 fqDecls :: A.Declaration -> [ModuleName]

204− fqDecls (A.TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) = [mn]

212+ fqDecls (A.TypeInstanceDeclaration _ _ q _ _) = getQual q

205− fqDecls (A.FixityDeclaration _ _ (Just (Qualified (Just mn) _))) = [mn]

213+ fqDecls (A.FixityDeclaration _ _ (Just eq)) = either getQual getQual eq

206 fqDecls _ = []

214 fqDecls _ = []

207

215

208 fqValues :: A.Expr -> [ModuleName]

216 fqValues :: A.Expr -> [ModuleName]

209− fqValues (A.Var (Qualified (Just mn) _)) = [mn]

217+ fqValues (A.Var q) = getQual q

210− fqValues (A.Constructor (Qualified (Just mn) _)) = [mn]

218+ fqValues (A.Constructor q) = getQual q

211 fqValues _ = []

219 fqValues _ = []

212

220

213 fqBinders :: A.Binder -> [ModuleName]

221 fqBinders :: A.Binder -> [ModuleName]

214− fqBinders (A.ConstructorBinder (Qualified (Just mn) _) _) = [mn]

222+ fqBinders (A.ConstructorBinder q _) = getQual q

215 fqBinders _ = []

223 fqBinders _ = []

216

224

225+ getQual :: Qualified a -> [ModuleName]

226+ getQual (Qualified (Just mn) _) = [mn]

227+ getQual _ = []

228+

217-- |

229-- |

218-- Desugars import declarations from AST to CoreFn representation.

230-- Desugars import declarations from AST to CoreFn representation.

219--

231--

src/Language/PureScript/Docs/Render.hs+5−1

@@ -61,7 +61,11 @@ renderDeclarationWithOptions opts Declaration{..} =

61 AliasDeclaration for (P.Fixity associativity precedence) ->

62 [ keywordFixity associativity

63 , syntax $ show precedence

64+ , ident $

65+ either

64− , ident $ P.showQualified P.runIdent $ dequalifyCurrentModule for

66+ (P.showQualified P.runIdent . dequalifyCurrentModule)

67+ (P.showQualified P.runProperName . dequalifyCurrentModule)

68+ for

65 , keyword "as"

69 , keyword "as"

66 , ident . tail . init $ declTitle

70 , ident . tail . init $ declTitle

67 ]

71 ]

src/Language/PureScript/Docs/Types.hs+5−2

@@ -133,7 +133,7 @@ data DeclarationInfo

133 -- An operator alias declaration, with the member the alias is for and the

134 -- operator's fixity.

135 --

136− | AliasDeclaration (P.Qualified P.Ident) P.Fixity

136+ | AliasDeclaration (Either (P.Qualified P.Ident) (P.Qualified (P.ProperName 'P.ConstructorName))) P.Fixity

137 deriving (Show, Eq, Ord)

138

139declInfoToString :: DeclarationInfo -> String

@@ -406,11 +406,14 @@ asDeclarationInfo = do

406 TypeClassDeclaration <$> key "arguments" asTypeArguments

407 <*> key "superclasses" (eachInArray asConstraint)

408 "alias" ->

409− AliasDeclaration <$> key "for" asQualifiedIdent

409+ AliasDeclaration <$> key "for" asAliasFor

410 <*> key "fixity" asFixity

411 other ->

412 throwCustomError (InvalidDeclarationType other)

413

414+asAliasFor :: Parse e (Either (P.Qualified P.Ident) (P.Qualified (P.ProperName 'P.ConstructorName)))

415+asAliasFor = fromAesonParser

416+

414asTypeArguments :: Parse PackageError [(String, Maybe P.Kind)]

417asTypeArguments :: Parse PackageError [(String, Maybe P.Kind)]

415asTypeArguments = eachInArray asTypeArgument

418asTypeArguments = eachInArray asTypeArgument

416 where

419 where

src/Language/PureScript/Errors.hs+13

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

113 | InvalidNewtype (ProperName 'TypeName)

114 | InvalidInstanceHead Type

115 | TransitiveExportError DeclarationRef [DeclarationRef]

116+ | TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName)

116 | ShadowedName Ident

117 | ShadowedName Ident

117 | ShadowedTypeVar String

118 | ShadowedTypeVar String

118 | UnusedTypeVar String

119 | UnusedTypeVar String

@@ -145,6 +146,7 @@ data SimpleErrorMessage

145 | HidingImport ModuleName [DeclarationRef]

146 | HidingImport ModuleName [DeclarationRef]

146 | CaseBinderLengthDiffers Int [Binder]

147 | CaseBinderLengthDiffers Int [Binder]

147 | IncorrectAnonymousArgument

148 | IncorrectAnonymousArgument

149+ | InvalidOperatorInBinder Ident Ident

148 deriving (Show)

150 deriving (Show)

149

151

150-- | Error message hints, providing more detailed information about failure.

152-- | Error message hints, providing more detailed information about failure.

@@ -290,6 +292,7 @@ errorCode em = case unwrapErrorMessage em of

290 InvalidNewtype{} -> "InvalidNewtype"

292 InvalidNewtype{} -> "InvalidNewtype"

291 InvalidInstanceHead{} -> "InvalidInstanceHead"

293 InvalidInstanceHead{} -> "InvalidInstanceHead"

292 TransitiveExportError{} -> "TransitiveExportError"

294 TransitiveExportError{} -> "TransitiveExportError"

295+ TransitiveDctorExportError{} -> "TransitiveDctorExportError"

293 ShadowedName{} -> "ShadowedName"

296 ShadowedName{} -> "ShadowedName"

294 ShadowedTypeVar{} -> "ShadowedTypeVar"

297 ShadowedTypeVar{} -> "ShadowedTypeVar"

295 UnusedTypeVar{} -> "UnusedTypeVar"

298 UnusedTypeVar{} -> "UnusedTypeVar"

@@ -322,6 +325,7 @@ errorCode em = case unwrapErrorMessage em of

322 HidingImport{} -> "HidingImport"

325 HidingImport{} -> "HidingImport"

323 CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"

326 CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"

324 IncorrectAnonymousArgument -> "IncorrectAnonymousArgument"

327 IncorrectAnonymousArgument -> "IncorrectAnonymousArgument"

328+ InvalidOperatorInBinder{} -> "InvalidOperatorInBinder"

325

329

326-- |

330-- |

327-- A stack trace for an error

331-- A stack trace for an error

@@ -789,6 +793,10 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

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

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

790 , indent $ paras $ map (line . prettyPrintExport) ys

794 , indent $ paras $ map (line . prettyPrintExport) ys

791 ]

795 ]

796+ renderSimpleErrorMessage (TransitiveDctorExportError x ctor) =

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

798+ , indent $ line $ runProperName ctor

799+ ]

792 renderSimpleErrorMessage (ShadowedName nm) =

800 renderSimpleErrorMessage (ShadowedName nm) =

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

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

794 renderSimpleErrorMessage (ShadowedTypeVar tv) =

802 renderSimpleErrorMessage (ShadowedTypeVar tv) =

@@ -952,6 +960,11 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

952 renderSimpleErrorMessage IncorrectAnonymousArgument =

960 renderSimpleErrorMessage IncorrectAnonymousArgument =

953 line "An anonymous function argument appears in an invalid context."

961 line "An anonymous function argument appears in an invalid context."

954

962

963+ renderSimpleErrorMessage (InvalidOperatorInBinder op fn) =

964+ paras $ [ line $ "Operator " ++ showIdent op ++ " cannot be used in a pattern as it is an alias for function " ++ showIdent fn ++ "."

965+ , line "Only aliases for data constructors may be used in patterns."

966+ ]

967+

955 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

968 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

956 renderHint (ErrorUnifyingTypes t1 t2) detail =

969 renderHint (ErrorUnifyingTypes t1 t2) detail =

957 paras [ detail

970 paras [ detail

src/Language/PureScript/Externs.hs+3−2

@@ -73,7 +73,7 @@ data ExternsFixity = ExternsFixity

73 -- | The operator symbol

74 , efOperator :: String

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

76− , efAlias :: Maybe (Qualified Ident)

76+ , efAlias :: Maybe (Either (Qualified Ident) (Qualified (ProperName 'ConstructorName)))

77 } deriving (Show, Read)

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

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

153 efDeclarations = concatMap toExternsDeclaration efExports

154

155 fixityDecl :: Declaration -> Maybe ExternsFixity

156+ fixityDecl (FixityDeclaration (Fixity assoc prec) op alias) =

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

157+ fmap (const (ExternsFixity assoc prec op alias)) (find exportsOp exps)

157 where

158 where

158 exportsOp :: DeclarationRef -> Bool

159 exportsOp :: DeclarationRef -> Bool

159 exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r

160 exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r

src/Language/PureScript/ModuleDependencies.hs+2−1

@@ -61,7 +61,8 @@ usedModules d =

61 where

62 forDecls :: Declaration -> [ModuleName]

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

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

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

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

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

66 forDecls (TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) = [mn]

66 forDecls _ = []

67 forDecls _ = []

src/Language/PureScript/Parser/Declarations.hs+21−4

@@ -122,9 +122,12 @@ parseFixityDeclaration :: TokenParser Declaration

122parseFixityDeclaration = do

123 fixity <- parseFixity

124 indented

125− alias <- P.optionMaybe $ parseQualified (Ident <$> identifier) <* reserved "as"

125+ alias <- P.optionMaybe $ aliased <* reserved "as"

126 name <- symbol

127 return $ FixityDeclaration fixity name alias

128+ where

129+ aliased = (Left <$> parseQualified (Ident <$> identifier))

130+ <|> (Right <$> parseQualified (ProperName <$> uname))

128

131

129parseImportDeclaration :: TokenParser Declaration

132parseImportDeclaration :: TokenParser Declaration

130parseImportDeclaration = do

133parseImportDeclaration = do

@@ -519,8 +522,19 @@ parseIdentifierAndBinder =

519-- Parse a binder

522-- Parse a binder

520--

523--

521parseBinder :: TokenParser Binder

524parseBinder :: TokenParser Binder

525+parseBinder =

526+ withSourceSpan

527+ PositionedBinder

528+ ( P.buildExpressionParser operators

522−parseBinder = withSourceSpan PositionedBinder (buildPostfixParser postfixTable parseBinderAtom)

529+ . buildPostfixParser postfixTable

530+ $ parseBinderAtom

531+ )

523 where

532 where

533+ operators =

534+ [ [ P.Infix (P.try (C.indented *> parseOpBinder P.<?> "binder operator") >>= \op ->

535+ return (BinaryNoParensBinder op)) P.AssocRight

536+ ]

537+ ]

524 -- TODO: parsePolyType when adding support for polymorphic types

538 -- TODO: parsePolyType when adding support for polymorphic types

525 postfixTable = [ \b -> flip TypedBinder b <$> (indented *> doubleColon *> parseType)

539 postfixTable = [ \b -> flip TypedBinder b <$> (indented *> doubleColon *> parseType)

526 ]

540 ]

@@ -535,9 +549,12 @@ parseBinder = withSourceSpan PositionedBinder (buildPostfixParser postfixTable p

535 , parseConstructorBinder

549 , parseConstructorBinder

536 , parseObjectBinder

550 , parseObjectBinder

537 , parseArrayBinder

551 , parseArrayBinder

538− , parens parseBinder

552+ , ParensInBinder <$> parens parseBinder

539 ] P.<?> "binder"

553 ] P.<?> "binder"

540

554

555+ parseOpBinder :: TokenParser Binder

556+ parseOpBinder = OpBinder <$> parseQualified (Op <$> symbol)

557+

541-- |

558-- |

542-- Parse a binder as it would appear in a top level declaration

559-- Parse a binder as it would appear in a top level declaration

543--

560--

@@ -552,7 +569,7 @@ parseBinderNoParens = P.choice

552 , parseNullaryConstructorBinder

569 , parseNullaryConstructorBinder

553 , parseObjectBinder

570 , parseObjectBinder

554 , parseArrayBinder

571 , parseArrayBinder

555− , parens parseBinder

572+ , ParensInBinder <$> parens parseBinder

556 ] P.<?> "binder"

573 ] P.<?> "binder"

557

574

558-- |

575-- |

src/Language/PureScript/Sugar/Names.hs+3−1

@@ -169,7 +169,7 @@ renameInModule env imports (Module ss coms mn decls exps) =

169 updateDecl (pos, bound) (ExternDeclaration name ty) =

170 (,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty)

171 updateDecl (pos, bound) (FixityDeclaration fx name alias) =

172− (,) (pos, bound) <$> (FixityDeclaration fx name <$> traverse (`updateValueName` pos) alias)

172+ (,) (pos, bound) <$> (FixityDeclaration fx name <$> traverse (eitherM (`updateValueName` pos) (`updateDataConstructorName` pos)) alias)

173 updateDecl s d = return (s, d)

174

175 updateValue

@@ -204,6 +204,8 @@ renameInModule env imports (Module ss coms mn decls exps) =

204 return ((Just pos, bound), v)

205 updateBinder s@(pos, _) (ConstructorBinder name b) =

206 (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)

207+ updateBinder s@(pos, _) (OpBinder name) =

208+ (,) s <$> (OpBinder <$> updateValueName name pos)

207 updateBinder s (TypedBinder t b) = do

209 updateBinder s (TypedBinder t b) = do

208 (s'@ (span', _), b') <- updateBinder s b

210 (s'@ (span', _), b') <- updateBinder s b

209 t' <- updateTypesEverywhere span' t

211 t' <- updateTypesEverywhere span' t

src/Language/PureScript/Sugar/Operators.hs+94−81

@@ -20,51 +20,92 @@ module Language.PureScript.Sugar.Operators (

20import Prelude ()

21import Prelude.Compat

23−import Language.PureScript.Crash

24import Language.PureScript.AST

23import Language.PureScript.AST

24+import Language.PureScript.Crash

25import Language.PureScript.Errors

26−import Language.PureScript.Names

27import Language.PureScript.Externs

26import Language.PureScript.Externs

27+import Language.PureScript.Names

28+import Language.PureScript.Sugar.Operators.Binders

29+import Language.PureScript.Sugar.Operators.Expr

30+import Language.PureScript.Traversals (defS)

29−import Control.Monad.State

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

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

31import Control.Monad.Supply.Class

33import Control.Monad.Supply.Class

33import Data.Function (on)

35import Data.Function (on)

34−import Data.Functor.Identity

35import Data.List (groupBy, sortBy)

36import Data.List (groupBy, sortBy)

36−import Data.Maybe (mapMaybe, fromMaybe)

37+import Data.Maybe (mapMaybe)

37import qualified Data.Map as M

38import qualified Data.Map as M

39−import qualified Text.Parsec as P

40−import qualified Text.Parsec.Pos as P

41−import qualified Text.Parsec.Expr as P

42−

43import qualified Language.PureScript.Constants as C

40import qualified Language.PureScript.Constants as C

42+-- TODO: in 0.9 operators names can have their own type rather than being in a sum with `Ident`, and `AliasName` no longer needs to be optional

43+

44+-- |

45+-- An operator associated with its declaration position, fixity, and the name

46+-- of the function or data constructor it is an alias for.

47+--

48+type FixityRecord = (Qualified Ident, SourceSpan, Fixity, Maybe AliasName)

49+

50+-- |

51+-- An operator can be an alias for a function or a data constructor.

52+--

53+type AliasName = Either (Qualified Ident) (Qualified (ProperName 'ConstructorName))

54+

45-- |

55-- |

46-- Remove explicit parentheses and reorder binary operator applications

56-- Remove explicit parentheses and reorder binary operator applications

47--

57--

58+rebracket

59+ :: forall m

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

60+ . (Applicative m, MonadError MultipleErrors m)

61+ => [ExternsFile]

62+ -> [Module]

63+ -> m [Module]

49rebracket externs ms = do

64rebracket externs ms = do

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

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

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

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

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

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

53 ms' <- traverse (rebracketModule opTable) ms

68 ms' <- traverse (rebracketModule opTable) ms

54 let aliased = M.fromList (mapMaybe makeLookupEntry fixities)

69 let aliased = M.fromList (mapMaybe makeLookupEntry fixities)

55− return $ renameAliasedOperators aliased `map` ms'

70+ mapM (renameAliasedOperators aliased) ms'

57 where

72 where

59− makeLookupEntry :: (Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident)) -> Maybe (Qualified Ident, Qualified Ident)

74+ makeLookupEntry :: FixityRecord -> Maybe (Qualified Ident, AliasName)

60 makeLookupEntry (qname, _, _, alias) = (qname, ) <$> alias

75 makeLookupEntry (qname, _, _, alias) = (qname, ) <$> alias

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

77+ renameAliasedOperators :: M.Map (Qualified Ident) AliasName -> Module -> m Module

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

78+ renameAliasedOperators aliased (Module ss coms mn ds exts) =

79+ Module ss coms mn <$> mapM f' ds <*> pure exts

64 where

80 where

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

81+ (f', _, _, _, _) = everywhereWithContextOnValuesM Nothing goDecl goExpr goBinder defS defS

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

82+

83+ goDecl :: Maybe SourceSpan -> Declaration -> m (Maybe SourceSpan, Declaration)

84+ goDecl _ d@(PositionedDeclaration pos _ _) = return (Just pos, d)

85+ goDecl pos other = return (pos, other)

86+

87+ goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr)

88+ goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e)

89+ goExpr pos (Var name) = return (pos, case name `M.lookup` aliased of

90+ Just (Left alias) -> Var alias

91+ Just (Right alias) -> Constructor alias

92+ Nothing -> Var name)

93+ goExpr pos other = return (pos, other)

94+

95+ goBinder :: Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder)

96+ goBinder _ b@(PositionedBinder pos _ _) = return (Just pos, b)

97+ goBinder pos (BinaryNoParensBinder (OpBinder name) lhs rhs) = case name `M.lookup` aliased of

98+ Just (Left alias) ->

99+ maybe id rethrowWithPosition pos $

100+ throwError . errorMessage $ InvalidOperatorInBinder (disqualify name) (disqualify alias)

101+ Just (Right alias) ->

102+ return (pos, ConstructorBinder alias [lhs, rhs])

103+ Nothing ->

104+ maybe id rethrowWithPosition pos $

105+ throwError . errorMessage $ UnknownValue name

106+ goBinder _ (BinaryNoParensBinder _ _ _) =

107+ internalError "BinaryNoParensBinder has no OpBinder"

67− go other = other

108+ goBinder pos other = return (pos, other)

109

69removeSignedLiterals :: Module -> Module

110removeSignedLiterals :: Module -> Module

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

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

@@ -74,35 +115,46 @@ removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds)

74 go (UnaryMinus val) = App (Var (Qualified Nothing (Ident C.negate))) val

115 go (UnaryMinus val) = App (Var (Qualified Nothing (Ident C.negate))) val

75 go other = other

116 go other = other

117

118+rebracketModule

77−rebracketModule :: (Applicative m, MonadError MultipleErrors m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> m Module

119+ :: (Applicative m, MonadError MultipleErrors m)

120+ => [[(Qualified Ident, Associativity)]]

121+ -> Module

122+ -> m Module

78rebracketModule opTable (Module ss coms mn ds exts) =

123rebracketModule opTable (Module ss coms mn ds exts) =

79− let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return

124+ let (f, _, _) = everywhereOnValuesTopDownM return (matchExprOperators opTable) (matchBinderOperators opTable)

80 in Module ss coms mn <$> (map removeParens <$> parU ds f) <*> pure exts

125 in Module ss coms mn <$> (map removeParens <$> parU ds f) <*> pure exts

126

82removeParens :: Declaration -> Declaration

127removeParens :: Declaration -> Declaration

83removeParens =

128removeParens =

84− let (f, _, _) = everywhereOnValues id go id

129+ let (f, _, _) = everywhereOnValues id goExpr goBinder

85 in f

130 in f

86 where

131 where

87− go (Parens val) = val

132+ goExpr (Parens val) = val

88− go val = val

133+ goExpr val = val

89−

134+ goBinder (ParensInBinder b) = b

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

135+ goBinder b = b

136+

137+externsFixities

138+ :: ExternsFile

139+ -> [FixityRecord]

91externsFixities ExternsFile{..} =

140externsFixities ExternsFile{..} =

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

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

93 | ExternsFixity assoc prec op alias <- efFixities

142 | ExternsFixity assoc prec op alias <- efFixities

94 ]

143 ]

144

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

145+collectFixities :: Module -> [FixityRecord]

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

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

98 where

147 where

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

148+ collect :: Declaration -> [FixityRecord]

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

149 collect (PositionedDeclaration pos _ (FixityDeclaration fixity name alias)) =

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

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

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

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

103 collect _ = []

152 collect _ = []

104

153

154+ensureNoDuplicates

105−ensureNoDuplicates :: (MonadError MultipleErrors m) => [(Qualified Ident, SourceSpan)] -> m ()

155+ :: MonadError MultipleErrors m

156+ => [(Qualified Ident, SourceSpan)]

157+ -> m ()

106ensureNoDuplicates m = go $ sortBy (compare `on` fst) m

158ensureNoDuplicates m = go $ sortBy (compare `on` fst) m

107 where

159 where

108 go [] = return ()

160 go [] = return ()

@@ -113,63 +165,24 @@ ensureNoDuplicates m = go $ sortBy (compare `on` fst) m

113 throwError . errorMessage $ MultipleFixities name

165 throwError . errorMessage $ MultipleFixities name

114 go (_ : rest) = go rest

166 go (_ : rest) = go rest

115

167

168+customOperatorTable

169+ :: [(Qualified Ident, Fixity)]

116−customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]]

170+ -> [[(Qualified Ident, Associativity)]]

117customOperatorTable fixities =

171customOperatorTable fixities =

118 let

172 let

119− applyUserOp ident t1 = App (App (Var ident) t1)

120− userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) fixities

173+ userOps = map (\(name, Fixity a p) -> (name, p, a)) fixities

121− sorted = sortBy (flip compare `on` (\(_, _, p, _) -> p)) userOps

174+ sorted = sortBy (flip compare `on` (\(_, p, _) -> p)) userOps

122− groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted

175+ groups = groupBy ((==) `on` (\(_, p, _) -> p)) sorted

123 in

176 in

124− map (map (\(name, f, _, a) -> (name, f, a))) groups

177+ map (map (\(name, _, a) -> (name, a))) groups

125−

178+

126−type Chain = [Either Expr Expr]

179+desugarOperatorSections

127−

180+ :: forall m

128−matchOperators :: forall m. (MonadError MultipleErrors m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Expr -> m Expr

129−matchOperators ops = parseChains

130− where

131− parseChains :: Expr -> m Expr

132− parseChains b@BinaryNoParens{} = bracketChain (extendChain b)

133− parseChains other = return other

134− extendChain :: Expr -> Chain

135− extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r

136− extendChain other = [Left other]

137− bracketChain :: Chain -> m Expr

138− bracketChain = either (\_ -> internalError "matchOperators: cannot reorder operators") return . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"

139− opTable = [P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft]

140− : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops

141− ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]

142−

143−toAssoc :: Associativity -> P.Assoc

144−toAssoc Infixl = P.AssocLeft

145−toAssoc Infixr = P.AssocRight

146−toAssoc Infix = P.AssocNone

147−

148−token :: (P.Stream s Identity t) => (t -> Maybe a) -> P.Parsec s u a

149−token = P.token (const "") (const (P.initialPos ""))

150−

151−parseValue :: P.Parsec Chain () Expr

152−parseValue = token (either Just (const Nothing)) P.<?> "expression"

153−

154−parseOp :: P.Parsec Chain () (Qualified Ident)

155−parseOp = token (either (const Nothing) fromOp) P.<?> "operator"

156− where

157− fromOp (Var q@(Qualified _ (Op _))) = Just q

158− fromOp _ = Nothing

159−

160−parseTicks :: P.Parsec Chain () Expr

161−parseTicks = token (either (const Nothing) fromOther) P.<?> "infix function"

162− where

163− fromOther (Var (Qualified _ (Op _))) = Nothing

164− fromOther v = Just v

165−

166−matchOp :: Qualified Ident -> P.Parsec Chain () ()

167−matchOp op = do

168− ident <- parseOp

169− guard $ ident == op

170−

171−desugarOperatorSections :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module

181+ . (Applicative m, MonadSupply m, MonadError MultipleErrors m)

182+ => Module

183+ -> m Module

172−desugarOperatorSections (Module ss coms mn ds exts) = Module ss coms mn <$> traverse goDecl ds <*> pure exts

184+desugarOperatorSections (Module ss coms mn ds exts) =

185+ Module ss coms mn <$> traverse goDecl ds <*> pure exts

173 where

186 where

174

187

175 goDecl :: Declaration -> m Declaration

188 goDecl :: Declaration -> m Declaration

src/Language/PureScript/Sugar/Operators/Binders.hsnew file+43

@@ -0,0 +1,43 @@

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

4+module Language.PureScript.Sugar.Operators.Binders where

6+import Prelude ()

7+import Prelude.Compat

9+import Control.Monad.Error.Class (MonadError(..))

10+

11+import qualified Text.Parsec as P

12+import qualified Text.Parsec.Expr as P

13+

14+import Language.PureScript.Crash

15+import Language.PureScript.AST

16+import Language.PureScript.Errors

17+import Language.PureScript.Names

18+import Language.PureScript.Sugar.Operators.Common

19+

20+matchBinderOperators

21+ :: forall m

22+ . MonadError MultipleErrors m

23+ => [[(Qualified Ident, Associativity)]]

24+ -> Binder

25+ -> m Binder

26+matchBinderOperators ops = parseChains

27+ where

28+ parseChains :: Binder -> m Binder

29+ parseChains b@BinaryNoParensBinder{} = bracketChain (extendChain b)

30+ parseChains other = return other

31+ extendChain :: Binder -> Chain Binder

32+ extendChain (BinaryNoParensBinder op l r) = Left l : Right op : extendChain r

33+ extendChain other = [Left other]

34+ bracketChain :: Chain Binder -> m Binder

35+ bracketChain =

36+ either

37+ (\_ -> internalError "matchBinderOperators: cannot reorder operators")

38+ return

39+ . P.parse opParser "operator expression"

40+ opParser = P.buildExpressionParser (opTable ops fromOp reapply) parseValue <* P.eof

41+ fromOp (OpBinder q@(Qualified _ (Op _))) = Just q

42+ fromOp _ = Nothing

43+ reapply = BinaryNoParensBinder . OpBinder

src/Language/PureScript/Sugar/Operators/Common.hsnew file+53

@@ -0,0 +1,53 @@

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

4+module Language.PureScript.Sugar.Operators.Common where

6+import Prelude ()

7+import Prelude.Compat

9+import Control.Monad.State

10+

11+import Data.Functor.Identity

12+

13+import qualified Text.Parsec as P

14+import qualified Text.Parsec.Pos as P

15+import qualified Text.Parsec.Expr as P

16+

17+import Language.PureScript.AST

18+import Language.PureScript.Names

19+

20+type Chain a = [Either a a]

21+

22+toAssoc :: Associativity -> P.Assoc

23+toAssoc Infixl = P.AssocLeft

24+toAssoc Infixr = P.AssocRight

25+toAssoc Infix = P.AssocNone

26+

27+token :: (P.Stream s Identity t) => (t -> Maybe a) -> P.Parsec s u a

28+token = P.token (const "") (const (P.initialPos ""))

29+

30+parseValue :: P.Parsec (Chain a) () a

31+parseValue = token (either Just (const Nothing)) P.<?> "expression"

32+

33+parseOp

34+ :: (a -> (Maybe (Qualified Ident)))

35+ -> P.Parsec (Chain a) () (Qualified Ident)

36+parseOp fromOp = token (either (const Nothing) fromOp) P.<?> "operator"

37+

38+matchOp

39+ :: (a -> (Maybe (Qualified Ident)))

40+ -> Qualified Ident

41+ -> P.Parsec (Chain a) () ()

42+matchOp fromOp op = do

43+ ident <- parseOp fromOp

44+ guard $ ident == op

45+

46+opTable

47+ :: [[(Qualified Ident, Associativity)]]

48+ -> (a -> Maybe (Qualified Ident))

49+ -> (Qualified Ident -> a -> a -> a)

50+ -> [[P.Operator (Chain a) () Identity a]]

51+opTable ops fromOp reapply =

52+ map (map (\(name, a) -> P.Infix (P.try (matchOp fromOp name) >> return (reapply name)) (toAssoc a))) ops

53+ ++ [[ P.Infix (P.try (parseOp fromOp >>= \ident -> return (reapply ident))) P.AssocLeft ]]

src/Language/PureScript/Sugar/Operators/Expr.hsnew file+52

@@ -0,0 +1,52 @@

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

4+module Language.PureScript.Sugar.Operators.Expr where

6+import Prelude ()

7+import Prelude.Compat

9+import Control.Monad.Error.Class (MonadError(..))

10+

11+import qualified Text.Parsec as P

12+import qualified Text.Parsec.Expr as P

13+

14+import Language.PureScript.Crash

15+import Language.PureScript.AST

16+import Language.PureScript.Errors

17+import Language.PureScript.Names

18+import Language.PureScript.Sugar.Operators.Common

19+

20+matchExprOperators

21+ :: forall m

22+ . MonadError MultipleErrors m

23+ => [[(Qualified Ident, Associativity)]]

24+ -> Expr

25+ -> m Expr

26+matchExprOperators ops = parseChains

27+ where

28+ parseChains :: Expr -> m Expr

29+ parseChains b@BinaryNoParens{} = bracketChain (extendChain b)

30+ parseChains other = return other

31+ extendChain :: Expr -> Chain Expr

32+ extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r

33+ extendChain other = [Left other]

34+ bracketChain :: Chain Expr -> m Expr

35+ bracketChain =

36+ either

37+ (\_ -> internalError "matchExprOperators: cannot reorder operators")

38+ return

39+ . P.parse opParser "operator expression"

40+ opParser = P.buildExpressionParser opTable' parseValue <* P.eof

41+ opTable' =

42+ [ P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft ]

43+ : opTable ops fromOp reapply

44+ fromOp (Var q@(Qualified _ (Op _))) = Just q

45+ fromOp _ = Nothing

46+ reapply op t1 t2 = App (App (Var op) t1) t2

47+

48+parseTicks :: P.Parsec (Chain Expr) () Expr

49+parseTicks = token (either (const Nothing) fromOther) P.<?> "infix function"

50+ where

51+ fromOther (Var (Qualified _ (Op _))) = Nothing

52+ fromOther v = Just v

src/Language/PureScript/TypeChecker.hs+41−18

@@ -19,7 +19,7 @@ import Language.PureScript.TypeChecker.Types as T

19import Language.PureScript.TypeChecker.Synonyms as T

21import Data.Maybe

22−import Data.List (nub, (\\), sort, group)

22+import Data.List (nub, nubBy, (\\), sort, group)

23import Data.Foldable (for_, traverse_)

25import qualified Data.Map as M

@@ -30,14 +30,14 @@ import Control.Monad.State.Class (MonadState(..), modify)

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

31import Control.Monad.Writer.Class (MonadWriter(..))

33−import Language.PureScript.Crash

34−import Language.PureScript.Types

35−import Language.PureScript.Names

36−import Language.PureScript.Kinds

37import Language.PureScript.AST

33import Language.PureScript.AST

38−import Language.PureScript.TypeClassDictionaries

34+import Language.PureScript.Crash

39import Language.PureScript.Environment

35import Language.PureScript.Environment

40import Language.PureScript.Errors

36import Language.PureScript.Errors

37+import Language.PureScript.Kinds

38+import Language.PureScript.Names

39+import Language.PureScript.TypeClassDictionaries

40+import Language.PureScript.Types

42addDataType

43 :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

@@ -281,9 +281,14 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

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

282

283 checkFixities :: Declaration -> m ()

284− checkFixities (FixityDeclaration _ name (Just alias)) = do

284+ checkFixities (FixityDeclaration _ name (Just (Left alias))) = do

285 ty <- lookupVariable moduleName alias

286 addValue moduleName (Op name) ty Public

287+ checkFixities (FixityDeclaration _ name (Just (Right alias))) = do

288+ env <- getEnv

289+ case M.lookup alias (dataConstructors env) of

290+ Nothing -> throwError . errorMessage $ UnknownDataConstructor alias Nothing

291+ Just (_, _, ty, _) -> addValue moduleName (Op name) ty Public

287 checkFixities (FixityDeclaration _ name _) = do

292 checkFixities (FixityDeclaration _ name _) = do

288 env <- getEnv

293 env <- getEnv

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

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

@@ -349,7 +354,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

349 checkTypesAreExported e

354 checkTypesAreExported e

350 checkClassMembersAreExported e

355 checkClassMembersAreExported e

351 checkClassesAreExported e

356 checkClassesAreExported e

352− checkNonAliasesAreExported e

357+ checkNonAliasesAreExported (exportedDataConstructors exps) e

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

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

354 where

359 where

355

360

@@ -374,7 +379,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

374 checkExport :: DeclarationRef -> (Type -> [DeclarationRef]) -> Type -> m ()

379 checkExport :: DeclarationRef -> (Type -> [DeclarationRef]) -> Type -> m ()

375 checkExport dr extract ty = case filter (not . exported) (extract ty) of

380 checkExport dr extract ty = case filter (not . exported) (extract ty) of

376 [] -> return ()

381 [] -> return ()

377− hidden -> throwError . errorMessage $ TransitiveExportError dr hidden

382+ hidden -> throwError . errorMessage $ TransitiveExportError dr (nubBy nubEq hidden)

378 where

383 where

379 exported e = any (exports e) exps

384 exported e = any (exports e) exps

380 exports (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2

385 exports (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2

@@ -383,6 +388,11 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

383 exports (PositionedDeclarationRef _ _ r1) r2 = exports r1 r2

388 exports (PositionedDeclarationRef _ _ r1) r2 = exports r1 r2

384 exports r1 (PositionedDeclarationRef _ _ r2) = exports r1 r2

389 exports r1 (PositionedDeclarationRef _ _ r2) = exports r1 r2

385 exports _ _ = False

390 exports _ _ = False

391+ -- We avoid Eq for `nub`bing as the dctor part of `TypeRef` evaluates to

392+ -- `error` for the values generated here (we don't need them anyway)

393+ nubEq (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2

394+ nubEq r1 r2 = r1 == r2

395+

386

396

387 -- Check that all the type constructors defined in the current module that appear in member types

397 -- Check that all the type constructors defined in the current module that appear in member types

388 -- have also been exported from the module

398 -- have also been exported from the module

@@ -425,17 +435,30 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

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

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

426 checkClassMembersAreExported _ = return ()

436 checkClassMembersAreExported _ = return ()

427

437

428− checkNonAliasesAreExported :: DeclarationRef -> m ()

438+ checkNonAliasesAreExported :: [ProperName 'ConstructorName] -> DeclarationRef -> m ()

429− checkNonAliasesAreExported dr@(ValueRef (Op name)) =

439+ checkNonAliasesAreExported exportedDctors dr@(ValueRef (Op name)) =

430 case listToMaybe (mapMaybe getAlias decls) of

440 case listToMaybe (mapMaybe getAlias decls) of

431− Just alias ->

441+ Just (Left ident) ->

432− unless (ValueRef alias `elem` exps) $

442+ unless (ValueRef ident `elem` exps) $

433− throwError . errorMessage $ TransitiveExportError dr [ValueRef alias]

443+ throwError . errorMessage $ TransitiveExportError dr [ValueRef ident]

444+ Just (Right ctor) ->

445+ unless (ctor `elem` exportedDctors) $

446+ throwError . errorMessage $ TransitiveDctorExportError dr ctor

434 _ -> return ()

447 _ -> return ()

435 where

448 where

436− getAlias :: Declaration -> Maybe Ident

449+ getAlias :: Declaration -> Maybe (Either Ident (ProperName 'ConstructorName))

437 getAlias (PositionedDeclaration _ _ d) = getAlias d

450 getAlias (PositionedDeclaration _ _ d) = getAlias d

438− getAlias (FixityDeclaration _ name' (Just (Qualified (Just mn') alias)))

451+ getAlias (FixityDeclaration _ name' (Just alias)) | name == name' =

439− | mn == mn' && name == name' = Just alias

452+ case alias of

453+ Left (Qualified (Just mn') ident) | mn == mn' -> Just (Left ident)

454+ Right (Qualified (Just mn') ctor) | mn == mn' -> Just (Right ctor)

455+ _ -> Nothing

440 getAlias _ = Nothing

456 getAlias _ = Nothing

441− checkNonAliasesAreExported _ = return ()

457+ checkNonAliasesAreExported _ _ = return ()

458+

459+ exportedDataConstructors :: [DeclarationRef] -> [ProperName 'ConstructorName]

460+ exportedDataConstructors = foldMap extractCtor

461+ where

462+ extractCtor :: DeclarationRef -> [ProperName 'ConstructorName]

463+ extractCtor (TypeRef _ (Just ctors)) = ctors

464+ extractCtor _ = []

src/Language/PureScript/TypeChecker/Types.hs+6

@@ -400,6 +400,12 @@ inferBinder val (TypedBinder ty binder) = do

400 ty1 <- replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

401 unifyTypes val ty1

402 inferBinder val binder

403+inferBinder _ OpBinder{} =

404+ internalError "OpBinder should have been desugared before inferBinder"

405+inferBinder _ BinaryNoParensBinder{} =

406+ internalError "BinaryNoParensBinder should have been desugared before inferBinder"

407+inferBinder _ ParensInBinder{} =

408+ internalError "ParensInBinder should have been desugared before inferBinder"

403

409

404-- | Returns true if a binder requires its argument type to be a monotype.

410-- | Returns true if a binder requires its argument type to be a monotype.

405-- | If this is the case, we need to instantiate any polymorphic types before checking binders.

411-- | If this is the case, we need to instantiate any polymorphic types before checking binders.