8d3b8b3 · rowtype-yoga/purescript-native

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

Introduce operator aliases

commit8d3b8b3c231fe8507e6abce029aa4b7316628a71 authorGary Burgess <gary.burgess@gmail.com> dateSun 6 Dec 2015, 17:42 (11 years ago) parentdd66f58

16 files changed+133−114

compare with golang

unifiedsplit

examples/failing/OperatorAliasNoExport.pursnew file+7

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

1+-- @shouldFailWith TransitiveExportError

2+module Test ((?!)) where

4+infixl 4 what as ?!

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

3+import Prelude

4+import Control.Monad.Eff.Console

6+infixl 4 what as ?!

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

9+what a _ = a

10+

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

purescript.cabal+1−1

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

11name: purescript

2−version: 0.7.6.1

2+version: 0.8.0.0

33cabal-version: >=1.8

44build-type: Simple

55license: MIT

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

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

186186 --

187187 | ExternDataDeclaration ProperName Kind

188188 -- |

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

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

190190 --

191− | FixityDeclaration Fixity String

191+ | FixityDeclaration Fixity String (Maybe Ident)

192192 -- |

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

194194 -- 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

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

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

114114 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'

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

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

118118 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−

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

162

173import Data.Function (on)

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

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

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

7056 [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))]

7160 declToCoreFn ss _ (A.BindingGroupDeclaration ds) =

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

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

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

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

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

4646 spacer

4747

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

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

4949

5050 for_ declComments tell'

5151

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

6868 elemAsMarkdown (Keyword x) = x

6969 elemAsMarkdown Space = " "

7070

71−fixityAsMarkdown :: P.Fixity -> Docs

72−fixityAsMarkdown (P.Fixity associativity precedence) =

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

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

73+ -- TODO: link alias name to member

7374 tell' $ concat [ "_"

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

7476 , associativityStr

7577 , " / precedence "

7678 , show precedence

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

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

1111 , collectBookmarks

1212 ) where

1313

14+import Prelude ()

15+import Prelude.Compat

16+

1417import Control.Monad

1518import Control.Category ((>>>))

1619import Data.Either

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

6871-- with their associativity and precedence.

6972data DeclarationAugment

7073 = AugmentChild ChildDeclaration

71− | AugmentFixity P.Fixity

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

7275

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

7477-- the type synonym IntermediateDeclaration for more information.

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

8689 case a of

8790 AugmentChild child ->

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

89− AugmentFixity fixity ->

90− d { declFixity = Just fixity }

92+ AugmentFixity fixity alias ->

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

9194

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

9396-- fixity declarations.

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

97100addDefaultFixity :: Declaration -> Declaration

98101addDefaultFixity decl@Declaration{..}

99102 | isOp declTitle && isNothing declFixity =

100− decl { declFixity = Just defaultFixity }

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

101104 | otherwise =

102105 decl

103106 where

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

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

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

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

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

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

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

118121getDeclarationTitle _ = Nothing

119122

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

170173

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

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

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

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

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

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

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

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

177180 where

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

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

8484 , declComments :: Maybe String

8585 , declSourceSpan :: Maybe P.SourceSpan

8686 , declChildren :: [ChildDeclaration]

87− , declFixity :: Maybe P.Fixity

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

8888 , declInfo :: DeclarationInfo

8989 }

9090 deriving (Show, Eq, Ord)

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

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

308308 <*> key "info" asDeclarationInfo

309309

310−asFixity :: Parse PackageError P.Fixity

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

312− <*> key "precedence" asIntegral

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

311+asFixity = do

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

313+ <*> key "precedence" asIntegral

314+ alias <- keyMay "alias" asString

315+ return (fixity, alias)

313316

314317parseAssociativity :: String -> Maybe P.Associativity

315318parseAssociativity str = case str of

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

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

127127 | UnusedExplicitImport ModuleName [String]

128128 | UnusedDctorImport ProperName

129129 | UnusedDctorExplicitImport ProperName [ProperName]

130+ | DeprecatedOperatorDecl String

130131 | DeprecatedQualifiedSyntax ModuleName ModuleName

131132 | DeprecatedClassImport ModuleName ProperName

132133 | DeprecatedClassExport ProperName

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

271272 UnusedExplicitImport{} -> "UnusedExplicitImport"

272273 UnusedDctorImport{} -> "UnusedDctorImport"

273274 UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"

275+ DeprecatedOperatorDecl{} -> "DeprecatedOperatorDecl"

274276 DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax"

275277 DeprecatedClassImport{} -> "DeprecatedClassImport"

276278 DeprecatedClassExport{} -> "DeprecatedClassExport"

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

712714 , 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."

713715 ]

714716 renderSimpleErrorMessage (TransitiveExportError x ys) =

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

716− : map (line . prettyPrintExport) ys

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

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

719+ ]

717720 renderSimpleErrorMessage (ShadowedName nm) =

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

719722 renderSimpleErrorMessage (ShadowedTypeVar tv) =

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

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

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

772775

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+

773783 renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) =

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

775785 , 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−

161{-# LANGUAGE RecordWildCards #-}

172{-# LANGUAGE PatternGuards #-}

183{-# LANGUAGE TemplateHaskell #-}

194

5+-- |

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

7+--

208module Language.PureScript.Externs

219 ( ExternsFile(..)

2210 , ExternsImport(..)

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

8472 , efPrecedence :: Precedence

8573 -- | The operator symbol

8674 , efOperator :: String

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

76+ , efAlias :: Maybe Ident

8777 } deriving (Show, Read)

8878

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

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

163153 efDeclarations = concatMap toExternsDeclaration efExports

164154

165155 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)

167157 where

168158 exportsOp :: DeclarationRef -> Bool

169159 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−

151{-# LANGUAGE FlexibleContexts #-}

162{-# LANGUAGE ScopedTypeVariables #-}

173{-# LANGUAGE PatternGuards #-}

184

5+-- |

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

7+--

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

209

2110import Prelude ()

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

6655 f dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec

6756

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

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

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

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

7060 where

7161 go :: Declaration -> MultipleErrors

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

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

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

7464 go _ = mempty

7565 stepD _ _ = mempty

7666

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

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

124124parseFixityDeclaration = do

125125 fixity <- parseFixity

126126 indented

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

127128 name <- symbol

128− return $ FixityDeclaration fixity name

129+ return $ FixityDeclaration fixity name alias

129130

130131parseImportDeclaration :: TokenParser Declaration

131132parseImportDeclaration = do

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

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

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

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

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

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

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

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

5253 updateExports exps _ = return exps

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

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

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

2−--

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

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

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

1+{-# LANGUAGE Rank2Types #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE RecordWildCards #-}

116-- |

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

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

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

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

1611-- it is necessary to reorder them here.

1712--

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

19−

20−{-# LANGUAGE Rank2Types #-}

21−{-# LANGUAGE FlexibleContexts #-}

22−{-# LANGUAGE ScopedTypeVariables #-}

23−{-# LANGUAGE RecordWildCards #-}

24−

2513module Language.PureScript.Sugar.Operators (

2614 rebracket,

2715 removeSignedLiterals,

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

4432import Data.Function (on)

4533import Data.Functor.Identity

4634import Data.List (groupBy, sortBy)

35+import Data.Maybe (mapMaybe, fromMaybe)

36+import qualified Data.Map as M

4737

4838import qualified Text.Parsec as P

4939import qualified Text.Parsec.Pos as P

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

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

5848rebracket externs ms = do

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

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

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

62− traverse (rebracketModule opTable) ms

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

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

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

6368

6469removeSignedLiterals :: Module -> Module

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

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

8287 go (Parens val) = val

8388 go val = val

8489

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

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

8691externsFixities ExternsFile{..} =

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

88− | ExternsFixity assoc prec op <- efFixities

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

93+ | ExternsFixity assoc prec op alias <- efFixities

8994 ]

9095

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

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

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

9398 where

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

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

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

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

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

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

97103 collect _ = []

98104

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−

161{-# LANGUAGE ScopedTypeVariables #-}

172{-# LANGUAGE FlexibleInstances #-}

183{-# LANGUAGE FlexibleContexts #-}

194

5+-- |

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

7+--

208module Language.PureScript.TypeChecker (

219 module T,

2210 typeCheckModule

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

196184 [DeclarationRef] ->

197185 [Declaration] ->

198186 m [Declaration]

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

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

200188 where

201189 go :: Declaration -> m Declaration

202190 go (DataDeclaration dtype name args dctors) = do

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

290278 go (PositionedDeclaration pos com d) =

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

292280

293− checkOrphanFixities :: Declaration -> m ()

294− checkOrphanFixities (FixityDeclaration _ name) = do

281+ checkFixities :: Declaration -> m ()

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

295286 env <- getEnv

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

297− checkOrphanFixities (PositionedDeclaration pos _ d) =

298− warnAndRethrowWithPosition pos $ checkOrphanFixities d

299− checkOrphanFixities _ = return ()

288+ checkFixities (PositionedDeclaration pos _ d) =

289+ warnAndRethrowWithPosition pos $ checkFixities d

290+ checkFixities _ = return ()

300291

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

302293 checkInstanceMembers instDecls = do

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

355346 checkTypesAreExported e

356347 checkClassMembersAreExported e

357348 checkClassesAreExported e

349+ checkNonAliasesAreExported e

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

359351 where

360352

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

429421 extractMemberName (TypeDeclaration memberName _) = memberName

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

431423 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 ()