6404180 · rowtype-yoga/purescript-native

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

Allow operator aliases for imported values

commit640418025a7b3cfeb673706da9b57da908e7bc32 authorGary Burgess <gary.burgess@gmail.com> dateMon 21 Dec 2015, 03:51 (11 years ago) parentebc4aac

16 files changed+94−56

compare with golang

unifiedsplit

examples/passing/OperatorAliasElsewhere.pursnew file+14

@@ -0,0 +1,14 @@

1+module Def where

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

4+what a _ = a

6+module Main where

8+import Prelude

9+import Def (what)

10+import Control.Monad.Eff.Console

11+

12+infixl 4 what as ?!

13+

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

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

@@ -186,7 +186,7 @@ data Declaration

186186 -- |

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

188188 --

189− | FixityDeclaration Fixity String (Maybe Ident)

189+ | FixityDeclaration Fixity String (Maybe (Qualified Ident))

190190 -- |

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

192192 -- 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/CoreFn/Desugar.hs+2−2

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

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

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

5757 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))]

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

6059 declToCoreFn ss _ (A.BindingGroupDeclaration ds) =

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

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

@@ -197,6 +196,7 @@ findQualModules decls =

197196 where

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

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

199+ fqDecls (A.FixityDeclaration _ _ (Just (Qualified (Just mn) _))) = [mn]

200200 fqDecls _ = []

201201

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

src/Language/PureScript/Docs/AsMarkdown.hs+8−9

@@ -31,21 +31,22 @@ moduleAsMarkdown Module{..} = do

3131 headerLevel 2 $ "Module " ++ modName

3232 spacer

3333 for_ modComments tell'

34− mapM_ declAsMarkdown modDeclarations

34+ mapM_ (declAsMarkdown modName) modDeclarations

3535 spacer

3636

37−declAsMarkdown :: Declaration -> Docs

38−declAsMarkdown decl@Declaration{..} = do

37+declAsMarkdown :: String -> Declaration -> Docs

38+declAsMarkdown mn decl@Declaration{..} = do

39+ let options = defaultRenderTypeOptions { currentModule = Just (P.moduleNameFromString mn) }

3940 headerLevel 4 (ticks declTitle)

4041 spacer

4142

4243 let (instances, children) = partition (isChildInstance . cdeclInfo) declChildren

4344 fencedBlock $ do

44− tell' (codeToString $ Render.renderDeclaration decl)

45+ tell' (codeToString $ Render.renderDeclarationWithOptions options decl)

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

4647 spacer

4748

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

49+ for_ declFixity (\fixity -> fixityAsMarkdown fixity >> spacer)

4950

5051 for_ declComments tell'

5152

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

6869 elemAsMarkdown (Keyword x) = x

6970 elemAsMarkdown Space = " "

7071

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

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

73− -- TODO: link alias name to member

72+fixityAsMarkdown :: P.Fixity -> Docs

73+fixityAsMarkdown (P.Fixity associativity precedence) =

7474 tell' $ concat [ "_"

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

7675 , associativityStr

7776 , " / precedence "

7877 , show precedence

src/Language/PureScript/Docs/Convert.hs+8−6

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

7171-- with their associativity and precedence.

7272data DeclarationAugment

7373 = AugmentChild ChildDeclaration

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

74+ | AugmentFixity P.Fixity

7575

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

7777-- the type synonym IntermediateDeclaration for more information.

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

8989 case a of

9090 AugmentChild child ->

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

92− AugmentFixity fixity alias ->

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

92+ AugmentFixity fixity ->

93+ d { declFixity = Just fixity }

9494

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

9696-- fixity declarations.

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

100100addDefaultFixity :: Declaration -> Declaration

101101addDefaultFixity decl@Declaration{..}

102102 | isOp declTitle && isNothing declFixity =

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

103+ decl { declFixity = Just defaultFixity }

104104 | otherwise =

105105 decl

106106 where

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

173173

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

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

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

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

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

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

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

179+ Just $ Right $ (mkDeclaration title (AliasDeclaration alias fixity)) { declFixity = Just fixity }

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

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

180182 where

src/Language/PureScript/Docs/Render.hs+11

@@ -61,8 +61,19 @@ renderDeclarationWithOptions opts Declaration{..} =

6161

6262 isTypeClassMember (ChildTypeClassMember _) = True

6363 isTypeClassMember _ = False

64+ AliasDeclaration for (P.Fixity associativity precedence) ->

65+ [ keywordFixity associativity

66+ , syntax $ show precedence

67+ , ident $ P.showQualified P.runIdent $ dequalifyCurrentModule for

68+ , keyword "as"

69+ , ident . tail . init $ declTitle

70+ ]

71+

6472 where

6573 renderType' = renderTypeWithOptions opts

74+ dequalifyCurrentModule (P.Qualified mn a)

75+ | mn == currentModule opts = P.Qualified Nothing a

76+ | otherwise = P.Qualified mn a

6677

6778renderChildDeclaration :: ChildDeclaration -> RenderedCode

6879renderChildDeclaration = renderChildDeclarationWithOptions defaultRenderTypeOptions

src/Language/PureScript/Docs/RenderedCode/Render.hs+7−2

@@ -9,7 +9,7 @@ module Language.PureScript.Docs.RenderedCode.Render (

99 defaultRenderTypeOptions,

1010 renderTypeWithOptions

1111) where

12−

12+

1313import Prelude ()

1414import Prelude.Compat

1515

@@ -172,10 +172,15 @@ renderType = renderTypeWithOptions defaultRenderTypeOptions

172172

173173data RenderTypeOptions = RenderTypeOptions

174174 { prettyPrintObjects :: Bool

175+ , currentModule :: Maybe ModuleName

175176 }

176177

177178defaultRenderTypeOptions :: RenderTypeOptions

178−defaultRenderTypeOptions = RenderTypeOptions { prettyPrintObjects = True }

179+defaultRenderTypeOptions =

180+ RenderTypeOptions

181+ { prettyPrintObjects = True

182+ , currentModule = Nothing

183+ }

179184

180185renderTypeWithOptions :: RenderTypeOptions -> Type -> RenderedCode

181186renderTypeWithOptions opts =

src/Language/PureScript/Docs/RenderedCode/Types.hs+6

@@ -28,6 +28,7 @@ module Language.PureScript.Docs.RenderedCode.Types

2828 , keywordClass

2929 , keywordInstance

3030 , keywordWhere

31+ , keywordFixity

3132 ) where

3233

3334import Prelude ()

@@ -189,3 +190,8 @@ keywordInstance = keyword "instance"

189190

190191keywordWhere :: RenderedCode

191192keywordWhere = keyword "where"

193+

194+keywordFixity :: P.Associativity -> RenderedCode

195+keywordFixity P.Infixl = keyword "infixl"

196+keywordFixity P.Infixr = keyword "infixr"

197+keywordFixity P.Infix = keyword "infix"

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

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

8484 , declComments :: Maybe String

8585 , declSourceSpan :: Maybe P.SourceSpan

8686 , declChildren :: [ChildDeclaration]

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

87+ , declFixity :: Maybe P.Fixity -- TODO: remove in 0.9

8888 , declInfo :: DeclarationInfo

8989 }

9090 deriving (Show, Eq, Ord)

@@ -126,6 +126,12 @@ data DeclarationInfo

126126 -- members are represented as child declarations.

127127 --

128128 | TypeClassDeclaration [(String, Maybe P.Kind)] [P.Constraint]

129+

130+ -- |

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

132+ -- operator's fixity.

133+ --

134+ | AliasDeclaration (P.Qualified P.Ident) P.Fixity

129135 deriving (Show, Eq, Ord)

130136

131137declInfoToString :: DeclarationInfo -> String

@@ -134,6 +140,7 @@ declInfoToString (DataDeclaration _ _) = "data"

134140declInfoToString (ExternDataDeclaration _) = "externData"

135141declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym"

136142declInfoToString (TypeClassDeclaration _ _) = "typeClass"

143+declInfoToString (AliasDeclaration _ _) = "alias"

137144

138145data ChildDeclaration = ChildDeclaration

139146 { cdeclTitle :: String

@@ -307,12 +314,10 @@ asDeclaration =

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

308315 <*> key "info" asDeclarationInfo

309316

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)

317+asFixity :: Parse PackageError P.Fixity

318+asFixity =

319+ P.Fixity <$> key "associativity" asAssociativity

320+ <*> key "precedence" asIntegral

316321

317322parseAssociativity :: String -> Maybe P.Associativity

318323parseAssociativity str = case str of

@@ -341,6 +346,9 @@ asDeclarationInfo = do

341346 "typeClass" ->

342347 TypeClassDeclaration <$> key "arguments" asTypeArguments

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

349+ "alias" ->

350+ AliasDeclaration <$> key "for" asQualifiedIdent

351+ <*> key "fixity" asFixity

344352 other ->

345353 throwCustomError (InvalidDeclarationType other)

346354

@@ -394,6 +402,9 @@ asConstraint = (,) <$> nth 0 asQualifiedProperName

394402asQualifiedProperName :: Parse e (P.Qualified P.ProperName)

395403asQualifiedProperName = fromAesonParser

396404

405+asQualifiedIdent :: Parse e (P.Qualified P.Ident)

406+asQualifiedIdent = fromAesonParser

407+

397408asBookmarks :: Parse BowerError [Bookmark]

398409asBookmarks = eachInArray asBookmark

399410

@@ -478,6 +489,7 @@ instance A.ToJSON DeclarationInfo where

478489 ExternDataDeclaration kind -> ["kind" .= kind]

479490 TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty]

480491 TypeClassDeclaration args super -> ["arguments" .= args, "superclasses" .= super]

492+ AliasDeclaration for fixity -> ["for" .= for, "fixity" .= fixity]

481493

482494instance A.ToJSON ChildDeclarationInfo where

483495 toJSON info = A.object $ "declType" .= childDeclInfoToString info : props

src/Language/PureScript/Externs.hs+1−1

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

7373 -- | The operator symbol

7474 , efOperator :: String

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

76− , efAlias :: Maybe Ident

76+ , efAlias :: Maybe (Qualified Ident)

7777 } deriving (Show, Read)

7878

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

src/Language/PureScript/ModuleDependencies.hs+1

@@ -58,6 +58,7 @@ usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (

5858 where

5959 forDecls :: Declaration -> [ModuleName]

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

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

6162 forDecls _ = []

6263

6364 forValues :: Expr -> [ModuleName]

src/Language/PureScript/Names.hs+1−16

@@ -13,10 +13,7 @@ import Control.Monad.Supply.Class

1313

1414import Data.List

1515import Data.Data

16−import Data.List.Split (splitOn)

1716import Data.Aeson.TH

18−import qualified Data.Aeson as A

19−import qualified Data.Text as T

2017

2118-- |

2219-- Names for value identifiers

@@ -81,19 +78,6 @@ showQualified :: (a -> String) -> Qualified a -> String

8178showQualified f (Qualified Nothing a) = f a

8279showQualified f (Qualified (Just name) a) = runModuleName name ++ "." ++ f a

8380

84−instance (a ~ ProperName) => A.ToJSON (Qualified a) where

85− toJSON = A.toJSON . showQualified runProperName

86−

87−instance (a ~ ProperName) => A.FromJSON (Qualified a) where

88− parseJSON =

89− A.withText "Qualified ProperName" $ \str ->

90− return $ case reverse (splitOn "." (T.unpack str)) of

91− [name] -> Qualified Nothing (ProperName name)

92− (name:rest) -> Qualified (Just (reconstructModuleName rest)) (ProperName name)

93− _ -> Qualified Nothing (ProperName "")

94− where

95− reconstructModuleName = moduleNameFromString . intercalate "." . reverse

96−

9781-- |

9882-- Provide a default module name, if a name is unqualified

9983--

@@ -118,6 +102,7 @@ isUnqualified :: Qualified a -> Bool

118102isUnqualified (Qualified Nothing _) = True

119103isUnqualified _ = False

120104

105+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Qualified)

121106$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident)

122107$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ProperName)

123108$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ModuleName)

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

@@ -122,7 +122,7 @@ parseFixityDeclaration :: TokenParser Declaration

122122parseFixityDeclaration = do

123123 fixity <- parseFixity

124124 indented

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

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

126126 name <- symbol

127127 return $ FixityDeclaration fixity name alias

128128

src/Language/PureScript/Sugar/Names.hs+2

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

141141 (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty)

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

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

144+ updateDecl (pos, bound) (FixityDeclaration fx name alias) =

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

144146 updateDecl s d = return (s, d)

145147

146148 updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> m ((Maybe SourceSpan, [Ident]), Expr)

src/Language/PureScript/Sugar/Operators.hs+9−9

@@ -2,6 +2,7 @@

22{-# LANGUAGE FlexibleContexts #-}

33{-# LANGUAGE ScopedTypeVariables #-}

44{-# LANGUAGE RecordWildCards #-}

5+{-# LANGUAGE TupleSections #-}

67-- |

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

@@ -55,9 +56,8 @@ rebracket externs ms = do

5556

5657 where

5758

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

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

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

6161

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

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

@@ -87,16 +87,16 @@ removeParens =

8787 go (Parens val) = val

8888 go val = val

8989

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

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

9191externsFixities ExternsFile{..} =

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

93− | ExternsFixity assoc prec op alias <- efFixities

94− ]

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

93+ | ExternsFixity assoc prec op alias <- efFixities

94+ ]

9595

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

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

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

9898 where

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

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

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

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

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

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

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

281281

282282 checkFixities :: Declaration -> m ()

283283 checkFixities (FixityDeclaration _ name (Just alias)) = do

284− ty <- lookupVariable moduleName (Qualified (Just moduleName) alias)

284+ ty <- lookupVariable moduleName alias

285285 addValue moduleName (Op name) ty Public

286286 checkFixities (FixityDeclaration _ name _) = do

287287 env <- getEnv

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

433433 where

434434 getAlias :: Declaration -> Maybe Ident

435435 getAlias (PositionedDeclaration _ _ d) = getAlias d

436− getAlias (FixityDeclaration _ name' alias) | name == name' = alias

436+ getAlias (FixityDeclaration _ name' (Just (Qualified (Just mn') alias)))

437+ | mn == mn' && name == name' = Just alias

437438 getAlias _ = Nothing

438439 checkNonAliasesAreExported _ = return ()