purescript · garyb · Dec 13, 2015 · Dec 6, 2015 · Dec 12, 2015 · hdgarrood
diff --git a/.gitmodules b/.gitmodules
@@ -0,0 +1,3 @@
+[submodule "tests/support/prelude"]
+	path = tests/support/prelude
+	url = https://github.com/purescript/purescript-prelude
diff --git a/examples/failing/OperatorAliasNoExport.purs b/examples/failing/OperatorAliasNoExport.purs
@@ -0,0 +1,7 @@
+-- @shouldFailWith TransitiveExportError
+module Test ((?!)) where
+
+infixl 4 what as ?!
+
+what :: forall a b. a -> b -> a
+what a _ = a
diff --git a/examples/passing/OperatorAlias.purs b/examples/passing/OperatorAlias.purs
@@ -0,0 +1,11 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console
+
+infixl 4 what as ?!
+
+what :: forall a b. a -> b -> a
+what a _ = a
+
+main = log $ "Done" ?! true
diff --git a/purescript.cabal b/purescript.cabal
@@ -1,5 +1,5 @@
 name: purescript
-version: 0.7.6.1
+version: 0.8.0.0
 cabal-version: >=1.8
 build-type: Simple
 license: MIT
@@ -261,10 +261,12 @@ test-suite tests
     build-depends: base >=4 && <5, containers -any, directory -any,
                    filepath -any, mtl -any, parsec -any, purescript -any,
                    transformers -any, process -any, transformers-compat -any, time -any,
-                   Glob -any, base-compat >=0.6.0
+                   Glob -any, aeson-better-errors -any, bytestring -any, aeson -any,
+                   base-compat -any
     type: exitcode-stdio-1.0
     main-is: Main.hs
     other-modules: TestsSetup
+                   TestPscPublish
     buildable: True
     hs-source-dirs: tests tests/common
 

diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
@@ -186,9 +186,9 @@ data Declaration
   --
   | ExternDataDeclaration ProperName Kind
   -- |
-  -- A fixity declaration (fixity data, operator name)
+  -- A fixity declaration (fixity data, operator name, value the operator is an alias for)
   --
-  | FixityDeclaration Fixity String
+  | FixityDeclaration Fixity String (Maybe Ident)
   -- |
   -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)
   -- TODO: also a boolean specifying whether the old `qualified` syntax was used, so a warning can be raised in desugaring (remove for 0.9)

diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs
@@ -112,7 +112,7 @@ isExported (Just exps) decl = any (matches decl) exps
   matches (TypeDeclaration ident _)          (ValueRef ident')     = ident == ident'
   matches (ValueDeclaration ident _ _ _)     (ValueRef ident')     = ident == ident'
   matches (ExternDeclaration ident _)        (ValueRef ident')     = ident == ident'
-  matches (FixityDeclaration _ name)         (ValueRef ident')     = name == runIdent ident'
+  matches (FixityDeclaration _ name _)       (ValueRef ident')     = name == runIdent ident'
   matches (DataDeclaration _ ident _ _)      (TypeRef ident' _)    = ident == ident'
   matches (ExternDataDeclaration ident _)    (TypeRef ident' _)    = ident == ident'
   matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _)    = ident == ident'

diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -1,17 +1,3 @@
------------------------------------------------------------------------------
---
--- Module      :  Language.PureScript.CoreFn.Desugar
--- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
--- License     :  MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
--- Stability   :  experimental
--- Portability :
---
--- | The AST -> CoreFn desugaring step
---
------------------------------------------------------------------------------
-
 module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where
 
 import Data.Function (on)
@@ -68,6 +54,9 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
   declToCoreFn ss _   (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds
   declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) =
     [NonRec name (exprToCoreFn ss com Nothing e)]
+  declToCoreFn ss com (A.FixityDeclaration _ name (Just alias)) =
+    let qname = Qualified (Just mn) alias
+    in [NonRec (Op name) (Var (ss, com, Nothing, getValueMeta qname) (Qualified Nothing alias))]
   declToCoreFn ss _   (A.BindingGroupDeclaration ds) =
     [Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds]
   declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =

diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs
@@ -45,7 +45,7 @@ declAsMarkdown decl@Declaration{..} = do
     zipWithM_ (\f c -> tell' (childToString f c)) (First : repeat NotFirst) children
   spacer
 
-  for_ declFixity (\fixity -> fixityAsMarkdown fixity >> spacer)
+  for_ declFixity (\(fixity, alias) -> fixityAsMarkdown fixity alias >> spacer)
 
   for_ declComments tell'
 
@@ -68,9 +68,11 @@ codeToString = outputWith elemAsMarkdown
   elemAsMarkdown (Keyword x) = x
   elemAsMarkdown Space       = " "
 
-fixityAsMarkdown :: P.Fixity -> Docs
-fixityAsMarkdown (P.Fixity associativity precedence) =
+fixityAsMarkdown :: P.Fixity -> Maybe String -> Docs
+fixityAsMarkdown (P.Fixity associativity precedence) alias =
+  -- TODO: link alias name to member
   tell' $ concat [ "_"
+                 , maybe "" (\i -> "alias for " ++ i ++ " - ") alias
                  , associativityStr
                  , " / precedence "
                  , show precedence

diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs
@@ -11,6 +11,9 @@ module Language.PureScript.Docs.Convert
   , collectBookmarks
   ) where
 
+import Prelude ()
+import Prelude.Compat
+
 import Control.Monad
 import Control.Category ((>>>))
 import Data.Either
@@ -68,7 +71,7 @@ type IntermediateDeclaration
 -- with their associativity and precedence.
 data DeclarationAugment
   = AugmentChild ChildDeclaration
-  | AugmentFixity P.Fixity
+  | AugmentFixity P.Fixity (Maybe P.Ident)
 
 -- | Augment top-level declarations; the second pass. See the comments under
 -- the type synonym IntermediateDeclaration for more information.
@@ -86,8 +89,8 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) =
     case a of
       AugmentChild child ->
         d { declChildren = declChildren d ++ [child] }
-      AugmentFixity fixity ->
-        d { declFixity = Just fixity }
+      AugmentFixity fixity alias ->
+        d { declFixity = Just (fixity, P.runIdent <$> alias) }
 
 -- | Add the default operator fixity for operators which do not have associated
 -- fixity declarations.
@@ -97,7 +100,7 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) =
 addDefaultFixity :: Declaration -> Declaration
 addDefaultFixity decl@Declaration{..}
   | isOp declTitle && isNothing declFixity =
-        decl { declFixity = Just defaultFixity }
+        decl { declFixity = Just (defaultFixity, Nothing) }
   | otherwise =
         decl
   where
@@ -113,7 +116,7 @@ getDeclarationTitle (P.ExternDataDeclaration name _)         = Just (P.runProper
 getDeclarationTitle (P.TypeSynonymDeclaration name _ _)      = Just (P.runProperName name)
 getDeclarationTitle (P.TypeClassDeclaration name _ _ _)      = Just (P.runProperName name)
 getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)
-getDeclarationTitle (P.FixityDeclaration _ name)             = Just ("(" ++ name ++ ")")
+getDeclarationTitle (P.FixityDeclaration _ name _)           = Just ("(" ++ name ++ ")")
 getDeclarationTitle (P.PositionedDeclaration _ _ d)          = getDeclarationTitle d
 getDeclarationTitle _                                        = Nothing
 
@@ -170,8 +173,8 @@ convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) tit
 
   childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)
   classApp = foldl P.TypeApp (P.TypeConstructor className) tys
-convertDeclaration (P.FixityDeclaration fixity _) title =
-  Just (Left ([title], AugmentFixity fixity))
+convertDeclaration (P.FixityDeclaration fixity _ alias) title =
+  Just (Left ([title], AugmentFixity fixity alias))
 convertDeclaration (P.PositionedDeclaration srcSpan com d') title =
   fmap (addComments . addSourceSpan) (convertDeclaration d' title)
   where

diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs
@@ -84,7 +84,7 @@ data Declaration = Declaration
   , declComments   :: Maybe String
   , declSourceSpan :: Maybe P.SourceSpan
   , declChildren   :: [ChildDeclaration]
-  , declFixity     :: Maybe P.Fixity
+  , declFixity     :: Maybe (P.Fixity, Maybe String)
   , declInfo       :: DeclarationInfo
   }
   deriving (Show, Eq, Ord)
@@ -307,9 +307,12 @@ asDeclaration =
               <*> key "fixity" (perhaps asFixity)
               <*> key "info" asDeclarationInfo
 
-asFixity :: Parse PackageError P.Fixity
-asFixity = P.Fixity <$> key "associativity" asAssociativity
-                    <*> key "precedence" asIntegral
+asFixity :: Parse PackageError (P.Fixity, Maybe String)
+asFixity = do
+  fixity <- P.Fixity <$> key "associativity" asAssociativity
+                     <*> key "precedence" asIntegral
+  alias <- keyMay "alias" asString
+  return (fixity, alias)
 
 parseAssociativity :: String -> Maybe P.Associativity
 parseAssociativity str = case str of

diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
@@ -127,6 +127,7 @@ data SimpleErrorMessage
   | UnusedExplicitImport ModuleName [String]
   | UnusedDctorImport ProperName
   | UnusedDctorExplicitImport ProperName [ProperName]
+  | DeprecatedOperatorDecl String
   | DeprecatedQualifiedSyntax ModuleName ModuleName
   | DeprecatedClassImport ModuleName ProperName
   | DeprecatedClassExport ProperName
@@ -271,6 +272,7 @@ errorCode em = case unwrapErrorMessage em of
   UnusedExplicitImport{} -> "UnusedExplicitImport"
   UnusedDctorImport{} -> "UnusedDctorImport"
   UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"
+  DeprecatedOperatorDecl{} -> "DeprecatedOperatorDecl"
   DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax"
   DeprecatedClassImport{} -> "DeprecatedClassImport"
   DeprecatedClassExport{} -> "DeprecatedClassExport"
@@ -712,8 +714,9 @@ prettyPrintSingleError full level e = do
             , 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."
             ]
     renderSimpleErrorMessage (TransitiveExportError x ys) =
-      paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")
-              : map (line . prettyPrintExport) ys
+      paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: "
+            , indent $ paras $ map (line . prettyPrintExport) ys
+            ]
     renderSimpleErrorMessage (ShadowedName nm) =
       line $ "Name '" ++ showIdent nm ++ "' was shadowed."
     renderSimpleErrorMessage (ShadowedTypeVar tv) =
@@ -770,6 +773,13 @@ prettyPrintSingleError full level e = do
       paras [ line $ "The import of type " ++ runProperName name ++ " includes the following unused data constructors:"
             , indent $ paras $ map (line .runProperName) names ]
 
+    renderSimpleErrorMessage (DeprecatedOperatorDecl name) =
+      paras [ line $ "The operator (" ++ name ++ ") was declared as a value rather than an alias for a named function."
+            , line "Operator aliases are declared by using a fixity declaration, for example:"
+            , indent $ line $ "infixl 9 someFunction as " ++ name
+            , line $ "Support for value-declared operators will be removed in PureScript 0.9."
+            ]
+
     renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) =
       paras [ line $ "Import uses the deprecated 'qualified' syntax:"
             , indent $ line $ "import qualified " ++ runModuleName name ++ " as " ++ runModuleName qualName

diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs
@@ -1,22 +1,10 @@
------------------------------------------------------------------------------
---
--- Module      :  Language.PureScript.Externs
--- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
--- License     :  MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer  :  Phil Freeman <paf31@cantab.net>
--- Stability   :  experimental
--- Portability :
---
--- |
--- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations.
---
------------------------------------------------------------------------------
-
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE PatternGuards #-}
 {-# LANGUAGE TemplateHaskell #-}
 
+-- |
+-- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations.
+--
 module Language.PureScript.Externs
   ( ExternsFile(..)
   , ExternsImport(..)
@@ -84,6 +72,8 @@ data ExternsFixity = ExternsFixity
   , efPrecedence :: Precedence
   -- | The operator symbol
   , efOperator :: String
+  -- | The value the operator is an alias for
+  , efAlias :: Maybe Ident
   } deriving (Show, Read)
 
 -- | A type or value declaration appearing in an externs file
@@ -163,7 +153,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}
   efDeclarations  = concatMap toExternsDeclaration efExports
 
   fixityDecl :: Declaration -> Maybe ExternsFixity
-  fixityDecl (FixityDeclaration (Fixity assoc prec) op) = fmap (const (ExternsFixity assoc prec op)) (find exportsOp exps)
+  fixityDecl (FixityDeclaration (Fixity assoc prec) op alias) = fmap (const (ExternsFixity assoc prec op alias)) (find exportsOp exps)
     where
     exportsOp :: DeclarationRef -> Bool
     exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r

diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs
@@ -1,21 +1,10 @@
------------------------------------------------------------------------------
---
--- Module      :  Language.PureScript.Linter
--- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
--- License     :  MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer  :  Phil Freeman <paf31@cantab.net>
--- Stability   :  experimental
--- Portability :
---
--- | This module implements a simple linting pass on the PureScript AST.
---
------------------------------------------------------------------------------
-
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE PatternGuards #-}
 
+-- |
+-- This module implements a simple linting pass on the PureScript AST.
+--
 module Language.PureScript.Linter (lint, module L) where
 
 import Prelude ()
@@ -66,11 +55,12 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl
     f dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec
 
     stepD :: S.Set Ident -> Declaration -> MultipleErrors
-    stepD _ (TypeClassDeclaration name _ _ decls) = foldMap go decls
+    stepD _ (ValueDeclaration (Op name) _ _ _) = errorMessage (DeprecatedOperatorDecl name)
+    stepD _ (TypeClassDeclaration _ _ _ decls) = foldMap go decls
       where
       go :: Declaration -> MultipleErrors
       go (PositionedDeclaration _ _ d') = go d'
-      go (TypeDeclaration op@(Op _) _)  = errorMessage (ClassOperator name op)
+      go (TypeDeclaration (Op name) _)  = errorMessage (DeprecatedOperatorDecl name)
       go _ = mempty
     stepD _ _ = mempty
 

diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
@@ -124,8 +124,9 @@ parseFixityDeclaration :: TokenParser Declaration
 parseFixityDeclaration = do
   fixity <- parseFixity
   indented
+  alias <- P.optionMaybe $ (Ident <$> identifier) <* reserved "as"
   name <- symbol
-  return $ FixityDeclaration fixity name
+  return $ FixityDeclaration fixity name alias
 
 parseImportDeclaration :: TokenParser Declaration
 parseImportDeclaration = do

diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs
@@ -47,6 +47,7 @@ findExportable (Module _ _ mn ds _) =
   updateExports exps (TypeSynonymDeclaration tn _ _) = exportType exps tn [] mn
   updateExports exps (ExternDataDeclaration tn _) = exportType exps tn [] mn
   updateExports exps (ValueDeclaration name _ _ _) = exportValue exps name mn
+  updateExports exps (FixityDeclaration _ name (Just _)) = exportValue exps (Op name) mn
   updateExports exps (ExternDeclaration name _) = exportValue exps name mn
   updateExports exps (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ updateExports exps d
   updateExports exps _ = return exps