fcc1ad5 · rowtype-yoga/purescript-native

.gitignore−1

compare with golang

unifiedsplit

@@ -14,7 +14,6 @@ bower_components/

14node_modules

15tmp/

16.stack-work/

17−tests/support/flattened/

18output

17output

19examples/docs/docs/

18examples/docs/docs/

20core-tests/full-core-docs.md

19core-tests/full-core-docs.md

.travis.yml+12−12

@@ -2,35 +2,35 @@ language: c

2sudo: false

3matrix:

4 include:

5− - env: GHCVER=7.8.4 COVERAGE_SUITE=tests

5+ - env: GHCVER=7.8.4 CABALVER=1.22 COVERAGE=true

6 compiler: ": #GHC 7.8.4 - tests"

7 # ^ HACK before https://github.com/travis-ci/travis-ci/issues/4393 is resolved

8 addons: {apt: {packages: [cabal-install-1.22,ghc-7.8.4,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}

9− - env: GHCVER=7.8.4 COVERAGE_SUITE=psci-tests

10− compiler: ": #GHC 7.8.4 - psci-tests"

11− addons: {apt: {packages: [cabal-install-1.22,ghc-7.8.4,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}

12− - env: GHCVER=7.8.4 STACKAGE=lts-2.22

9+ - env: GHCVER=7.8.4 CABALVER=1.22 STACKAGE=lts-2.22

13 compiler: ": #GHC 7.8.4 - lts-2.22-1"

10 compiler: ": #GHC 7.8.4 - lts-2.22-1"

14 addons: {apt: {packages: [cabal-install-1.22,ghc-7.8.4,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}

11 addons: {apt: {packages: [cabal-install-1.22,ghc-7.8.4,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}

15− - env: GHCVER=7.6.3

12+ - env: GHCVER=7.6.3 CABALVER=1.22

16 compiler: ": #GHC 7.6.3"

13 compiler: ": #GHC 7.6.3"

17 addons: {apt: {packages: [cabal-install-1.22,ghc-7.6.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}

14 addons: {apt: {packages: [cabal-install-1.22,ghc-7.6.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}

18− - env: GHCVER=7.10.1 DEPLOY=yes

15+ - env: GHCVER=7.10.1 CABALVER=1.22 DEPLOY=yes

19 compiler: ": #GHC 7.10.1"

16 compiler: ": #GHC 7.10.1"

20 addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}

17 addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}

21− - env: GHCVER=7.10.2 STACKAGE=lts=3.6 RUNSDISTTESTS=YES

18+ - env: GHCVER=7.10.2 CABALVER=1.22 STACKAGE=lts=3.6 RUNSDISTTESTS=YES

22 compiler: ": #GHC 7.10.2 lts-3.6"

19 compiler: ": #GHC 7.10.2 lts-3.6"

23 addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}

20 addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}

24− - env: GHCVER=7.10.2 STACKAGE=nightly-2015-09-29

21+ - env: GHCVER=7.10.2 CABALVER=1.22 STACKAGE=nightly-2015-09-29

25 compiler: ": #GHC 7.10.2 nightly-2015-09-29"

22 compiler: ": #GHC 7.10.2 nightly-2015-09-29"

26 addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}

23 addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}

27− - env: GHCVER=7.10.3

24+ - env: GHCVER=7.10.3 CABALVER=1.22

28 compiler: ": #GHC 7.10.3"

25 compiler: ": #GHC 7.10.3"

29 addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}

26 addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}

27+ - env: GHCVER=8.0.1 CABALVER=1.24

28+ compiler: ": #GHC 8.0.1"

29+ addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}

30before_install:

31 - unset CC

32 - export PATH="/opt/ghc/$GHCVER/bin:$PATH"

33− - export PATH="/opt/cabal/1.22/bin:$PATH"

33+ - export PATH="/opt/cabal/$CABALVER/bin:$PATH"

34 - export PATH="$HOME/.cabal/bin:$PATH"

35 - export PATH="/opt/happy/1.19.5/bin:/$PATH"

36 - export PATH="/opt/alex/3.1.4/bin:/$PATH"

@@ -51,7 +51,7 @@ install:

51 - mkdir -p .cabal-sandbox

52 - cabal sandbox init --sandbox .cabal-sandbox

53 # Download stackage cabal.config, not sure whether filtering is necessary

54− - if [ -n "$STACKAGE" ]; then curl http://www.stackage.org/$STACKAGE/cabal.config | grep -v purescript > cabal.config; fi

54+ - if [ -n "$STACKAGE" ]; then curl https://www.stackage.org/$STACKAGE/cabal.config | grep -v purescript > cabal.config; fi

55 - cabal install --only-dependencies --enable-tests

56 - cabal install hpc-coveralls

57 # Snapshot state of the sandbox now, so we don't need to make new one for test install

CONTRIBUTORS.md+1

@@ -65,6 +65,7 @@ This file lists the contributors to the PureScript compiler project, and the ter

65- [@codedmart](https://github.com/codedmart) (Brandon Martin) My existing contributions and all future contributions until further notice are Copyright Brandon Martin, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

66- [@passy](https://github.com/passy) (Pascal Hartig) My existing contributions and all future contributions until further notice are Copyright Pascal Hartig, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

67- [@DavidLindbom](https://github.com/DavidLindbom) (David Lindbom) My existing contributions and all future contributions until further notice are Copyright David Lindbom, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

68+- [@izgzhen](https://github.com/izgzhen) (Zhen Zhang) My existing contributions and all future contributions until further notice are Copyright Zhen Zhang, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

68

69

69### Companies

70### Companies

70

71

examples/docs/src/ExplicitTypeSignatures.pursnew file+16

@@ -0,0 +1,16 @@

1+

2+module ExplicitTypeSignatures where

3+

4+-- This should use the explicit type signature so that the type variable name

5+-- is preserved.

6+explicit :: forall something. something -> something

7+explicit x

8+ | true = x

9+ | false = x

10+

11+-- This should use the inferred type.

12+anInt :: _

13+anInt = 0

14+

15+-- This should infer a type.

16+aNumber = 1.0

examples/failing/AnonArgument1.pursnew file+5

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

1+-- @shouldFailWith IncorrectAnonymousArgument

2+module Main where

3+

4+test :: Int -> Int

5+test = _

examples/failing/AnonArgument2.pursnew file+7

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

1+-- @shouldFailWith IncorrectAnonymousArgument

2+module Main where

3+

4+import Prelude

5+

6+test :: Int -> Int

7+test = 1 + 2 * _

examples/failing/AnonArgument3.pursnew file+5

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

1+-- @shouldFailWith IncorrectAnonymousArgument

2+module Main where

3+

4+test :: Int -> Int

5+test = 1 + _

examples/failing/DctorOperatorAliasExport.pursnew file+6

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

1+-- @shouldFailWith TransitiveDctorExportError

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

3+

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

5+

6+ infixr 6 Cons as :

examples/failing/InvalidOperatorInBinder.pursnew file+12

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

1+-- @shouldFailWith InvalidOperatorInBinder

2+module Main where

3+

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

5+

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

7+cons = Cons

8+

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

2+

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

4+

5+ infixr 6 Cons as :

6+

7+module Main where

8+

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"

examples/passing/Deriving.pursnew file+31

@@ -0,0 +1,31 @@

1+module Main where

2+

3+import Prelude

4+import Test.Assert

5+

6+data V

7+

8+derive instance eqV :: Eq V

9+

10+derive instance ordV :: Ord V

11+

12+data X = X Int | Y String

13+

14+derive instance eqX :: Eq X

15+

16+derive instance ordX :: Ord X

17+

18+newtype Z = Z { left :: X, right :: X }

19+

20+derive instance eqZ :: Eq Z

21+

22+main = do

23+ assert $ X 0 == X 0

24+ assert $ X 0 /= X 1

25+ assert $ Y "Foo" == Y "Foo"

26+ assert $ Y "Foo" /= Y "Bar"

27+ assert $ X 0 < X 1

28+ assert $ X 0 < Y "Foo"

29+ assert $ Y "Bar" < Y "Baz"

30+ assert $ z == z where

31+ z = Z { left: X 0, right: Y "Foo" }

examples/passing/ExplicitOperatorSections.pursnew file+14

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

1+module Main where

2+

3+import Prelude

4+

5+subtractOne :: Int -> Int

6+subtractOne = (_ - 1)

7+

8+addOne :: Int -> Int

9+addOne = (1 + _)

10+

11+named :: Int -> Int

12+named = (_ `sub` 1)

13+

14+main = Control.Monad.Eff.Console.log "Done"

psc-docs/Main.hs+6−6

@@ -69,19 +69,19 @@ docgen (PSCDocsOptions fmt inputGlob output) = do

69 Etags -> dumpTags input dumpEtags

70 Ctags -> dumpTags input dumpCtags

71 Markdown -> do

72− ms <- runExceptT (D.parseAndDesugar input []

72+ ms <- runExceptT (D.parseAndBookmark input []

73− >>= ((\(ms, _, env) -> D.convertModulesInPackage env ms)))

73+ >>= (fst >>> D.convertModulesInPackage))

74 >>= successOrExit

75

76 case output of

77 EverythingToStdOut ->

78 putStrLn (D.runDocs (D.modulesAsMarkdown ms))

79 ToStdOut names -> do

80− let (ms', missing) = takeByName ms (map P.runModuleName names)

80+ let (ms', missing) = takeByName ms names

81 guardMissing missing

82 putStrLn (D.runDocs (D.modulesAsMarkdown ms'))

83 ToFiles names -> do

84− let (ms', missing) = takeByName' ms (map (first P.runModuleName) names)

84+ let (ms', missing) = takeByName' ms names

85 guardMissing missing

86

87 let ms'' = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ map swap ms'

@@ -93,12 +93,12 @@ docgen (PSCDocsOptions fmt inputGlob output) = do

93 where

94 guardMissing [] = return ()

95 guardMissing [mn] = do

96− hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ mn ++ "\"")

96+ hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ P.runModuleName mn ++ "\"")

97 exitFailure

98 guardMissing mns = do

99 hPutStrLn stderr "psc-docs: error: unknown modules:"

100 forM_ mns $ \mn ->

101− hPutStrLn stderr (" * " ++ mn)

101+ hPutStrLn stderr (" * " ++ P.runModuleName mn)

102 exitFailure

103

104 successOrExit :: Either P.MultipleErrors a -> IO a

psci/IO.hsdeleted−21

@@ -1,21 +0,0 @@

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

2−--

3−-- Module : IO

5−-- License : MIT

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−--

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

14−

15−module IO where

16−

17−import System.Directory (createDirectoryIfMissing)

18−import System.FilePath (takeDirectory)

19−

20−mkdirp :: FilePath -> IO ()

21−mkdirp = createDirectoryIfMissing True . takeDirectory

psci/PSCi.hs+123−453

@@ -7,16 +7,14 @@

7-- |

8-- PureScript Compiler Interactive.

9--

10−module PSCi where

10+module PSCi (runPSCi) where

11

12import Prelude ()

13import Prelude.Compat

14

15import Data.Foldable (traverse_)

16−import Data.Maybe (mapMaybe)

17−import Data.List (intersperse, intercalate, nub, sort, find)

16+import Data.List (intercalate, nub, sort, find)

18import Data.Tuple (swap)

17import Data.Tuple (swap)

19−import Data.Version (showVersion)

20import qualified Data.Map as M

18import qualified Data.Map as M

21

19

22import Control.Arrow (first)

20import Control.Arrow (first)

@@ -24,102 +22,87 @@ import Control.Monad

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

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

25import Control.Monad.Trans.Class

23import Control.Monad.Trans.Class

26import Control.Monad.Trans.Except (ExceptT(), runExceptT)

24import Control.Monad.Trans.Except (ExceptT(), runExceptT)

27−import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

28import Control.Monad.Trans.State.Strict

25import Control.Monad.Trans.State.Strict

29import Control.Monad.IO.Class (liftIO)

26import Control.Monad.IO.Class (liftIO)

30import Control.Monad.Writer.Strict (Writer(), runWriter)

27import Control.Monad.Writer.Strict (Writer(), runWriter)

31

28

32−import Options.Applicative as Opts

33−

34import System.Console.Haskeline

29import System.Console.Haskeline

35−import System.Directory (doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)

30+import System.Directory (doesFileExist, getHomeDirectory, getCurrentDirectory)

36import System.Exit

31import System.Exit

37−import System.FilePath (pathSeparator, (</>), isPathSeparator)

32+import System.FilePath ((</>))

38import System.FilePath.Glob (glob)

33import System.FilePath.Glob (glob)

39import System.Process (readProcessWithExitCode)

34import System.Process (readProcessWithExitCode)

40import System.IO.Error (tryIOError)

35import System.IO.Error (tryIOError)

41−import qualified Text.PrettyPrint.Boxes as Box

42

36

43import qualified Language.PureScript as P

37import qualified Language.PureScript as P

44import qualified Language.PureScript.Names as N

38import qualified Language.PureScript.Names as N

45−import qualified Paths_purescript as Paths

46−

47−import qualified Directive as D

48−import Completion (completion)

49−import IO (mkdirp)

50−import Parser (parseCommand)

51−import Types

52−

53−-- | The name of the PSCI support module

54−supportModuleName :: P.ModuleName

55−supportModuleName = P.ModuleName [P.ProperName "$PSCI", P.ProperName "Support"]

56−

57−-- | Support module, contains code to evaluate terms

58−supportModule :: P.Module

59−supportModule =

60− case P.parseModulesFromFiles id [("", code)] of

61− Right [(_, P.Module ss cs _ ds exps)] -> P.Module ss cs supportModuleName ds exps

62− _ -> P.internalError "Support module could not be parsed"

63− where

64− code :: String

65− code = unlines

66− [ "module S where"

67− , ""

68− , "import Prelude"

69− , "import Control.Monad.Eff"

70− , "import Control.Monad.Eff.Console"

71− , "import Control.Monad.Eff.Unsafe"

72− , ""

73− , "class Eval a where"

74− , " eval :: a -> Eff (console :: CONSOLE) Unit"

75− , ""

76− , "instance evalShow :: (Show a) => Eval a where"

77− , " eval = print"

78− , ""

79− , "instance evalEff :: (Eval a) => Eval (Eff eff a) where"

80− , " eval x = unsafeInterleaveEff x >>= eval"

81− ]

82−

83−-- File helpers

84−

85−onFirstFileMatching :: Monad m => (b -> m (Maybe a)) -> [b] -> m (Maybe a)

86−onFirstFileMatching f pathVariants = runMaybeT . msum $ map (MaybeT . f) pathVariants

87

39

88−-- |

40+import PSCi.Completion (completion)

89−-- Locates the node executable.

41+import PSCi.Parser (parseCommand)

90−-- Checks for either @nodejs@ or @node@.

42+import PSCi.Option

91−--

43+import PSCi.Types

92−findNodeProcess :: IO (Maybe String)

44+import PSCi.Message

93−findNodeProcess = onFirstFileMatching findExecutable names

45+import PSCi.IO

94− where names = ["nodejs", "node"]

46+import PSCi.Printer

47+import PSCi.Module

95

48

96-- |

49-- |

97−-- Grabs the filename where the history is stored.

50+-- PSCI monad

98--

51--

99−getHistoryFilename :: IO FilePath

52+newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)

100−getHistoryFilename = do

53+

101− home <- getHomeDirectory

54+psciIO :: IO a -> PSCI a

102− let filename = home </> ".purescript" </> "psci_history"

55+psciIO io = PSCI . lift $ lift io

103− mkdirp filename

104− return filename

105

56

106-- |

57-- |

107−-- Loads a file for use with imports.

58+-- The runner

108--

59--

109−loadModule :: FilePath -> IO (Either String [P.Module])

60+runPSCi :: IO ()

110−loadModule filename = do

61+runPSCi = getOpt >>= loop

111− content <- readFile filename

112− return $ either (Left . P.prettyPrintMultipleErrors False) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]

113

62

114-- |

63-- |

115−-- Load all modules.

64+-- The PSCI main loop.

116--

65--

117−loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)])

66+loop :: PSCiOptions -> IO ()

118−loadAllModules files = do

67+loop PSCiOptions{..} = do

119− filesAndContent <- forM files $ \filename -> do

68+ config <- loadUserConfig

120− content <- readFile filename

69+ inputFiles <- concat <$> traverse glob psciInputFile

121− return (filename, content)

70+ foreignFiles <- concat <$> traverse glob psciForeignInputFiles

122− return $ P.parseModulesFromFiles id filesAndContent

71+ modulesOrFirstError <- loadAllModules inputFiles

72+ case modulesOrFirstError of

73+ Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure

74+ Right modules -> do

75+ historyFilename <- getHistoryFilename

76+ let settings = defaultSettings { historyFile = Just historyFilename }

77+ foreignsOrError <- runMake $ do

78+ foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.ErrorMessage [] $ P.CannotReadFile inFile)) (readFile inFile))

79+ P.parseForeignModulesFromFiles foreignFilesContent

80+ case foreignsOrError of

81+ Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure

82+ Right foreigns ->

83+ flip evalStateT (mkPSCiState [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do

84+ outputStrLn prologueMessage

85+ traverse_ (traverse_ (runPSCI . handleCommand)) config

86+ modules' <- lift $ gets psciLoadedModules

87+ unless (consoleIsDefined (map snd modules')) . outputStrLn $ unlines

88+ [ "PSCi requires the purescript-console module to be installed."

89+ , "For help getting started, visit http://wiki.purescript.org/PSCi"

90+ ]

91+ go

92+ where

93+ go :: InputT (StateT PSCiState IO) ()

94+ go = do

95+ c <- getCommand (not psciMultiLineMode)

96+ case c of

97+ Left err -> outputStrLn err >> go

98+ Right Nothing -> go

99+ Right (Just QuitPSCi) -> outputStrLn quitMessage

100+ Right (Just c') -> do

101+ handleInterrupt (outputStrLn "Interrupted.")

102+ (withInterrupt (runPSCI (loadAllImportedModules >> handleCommand c')))

103+ go

104+

105+-- Compile the module

123

106

124-- |

107-- |

125-- Load all modules, updating the application state

108-- Load all modules, updating the application state

@@ -129,116 +112,9 @@ loadAllImportedModules = do

129 files <- PSCI . lift $ fmap psciImportedFilenames get

112 files <- PSCI . lift $ fmap psciImportedFilenames get

130 modulesOrFirstError <- psciIO $ loadAllModules files

113 modulesOrFirstError <- psciIO $ loadAllModules files

131 case modulesOrFirstError of

114 case modulesOrFirstError of

132− Left errs -> printErrors errs

115+ Left errs -> PSCI $ printErrors errs

133 Right modules -> PSCI . lift . modify $ updateModules modules

116 Right modules -> PSCI . lift . modify $ updateModules modules

134

117

135−-- |

136−-- Expands tilde in path.

137−--

138−expandTilde :: FilePath -> IO FilePath

139−expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory

140−expandTilde p = return p

141−

142−-- Messages

143−

144−-- |

145−-- The help message.

146−--

147−helpMessage :: String

148−helpMessage = "The following commands are available:\n\n " ++

149− intercalate "\n " (map line D.help) ++

150− "\n\n" ++ extraHelp

151− where

152− line :: (Directive, String, String) -> String

153− line (dir, arg, desc) =

154− let cmd = ':' : D.stringFor dir

155− in unwords [ cmd

156− , replicate (11 - length cmd) ' '

157− , arg

158− , replicate (11 - length arg) ' '

159− , desc

160− ]

161−

162− extraHelp =

163− "Further information is available on the PureScript wiki:\n" ++

164− " --> https://github.com/purescript/purescript/wiki/psci"

165−

166−

167−-- |

168−-- The welcome prologue.

169−--

170−prologueMessage :: String

171−prologueMessage = intercalate "\n"

172− [ " ____ ____ _ _ "

173− , "| _ \\ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_ "

174− , "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|"

175− , "| __/| |_| | | | __/___) | (__| | | | |_) | |_ "

176− , "|_| \\__,_|_| \\___|____/ \\___|_| |_| .__/ \\__|"

177− , " |_| "

178− , ""

179− , ":? shows help"

180− ]

181−

182−-- |

183−-- The quit message.

184−--

185−quitMessage :: String

186−quitMessage = "See ya!"

187−

188−-- |

189−-- PSCI monad

190−--

191−newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)

192−

193−psciIO :: IO a -> PSCI a

194−psciIO io = PSCI . lift $ lift io

195−

196−-- |

197−-- Makes a volatile module to execute the current expression.

198−--

199−createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module

200−createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindings = lets} val =

201− let

202− moduleName = P.ModuleName [P.ProperName "$PSCI"]

203− trace = P.Var (P.Qualified (Just supportModuleName) (P.Ident "eval"))

204− mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))

205− itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val

206− mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] $ Right mainValue

207− decls = if exec then [itDecl, mainDecl] else [itDecl]

208− in

209− P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing

210−

211−

212−-- |

213−-- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration.

214−--

215−createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module

216−createTemporaryModuleForKind PSCiState{psciImportedModules = imports, psciLetBindings = lets} typ =

217− let

218− moduleName = P.ModuleName [P.ProperName "$PSCI"]

219− itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ

220− in

221− P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing

222−

223−-- |

224−-- Makes a volatile module to execute the current imports.

225−--

226−createTemporaryModuleForImports :: PSCiState -> P.Module

227−createTemporaryModuleForImports PSCiState{psciImportedModules = imports} =

228− let

229− moduleName = P.ModuleName [P.ProperName "$PSCI"]

230− in

231− P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName (importDecl `map` imports) Nothing

232−

233−importDecl :: ImportedModule -> P.Declaration

234−importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ False

235−

236−indexFile :: FilePath

237−indexFile = ".psci_modules" ++ pathSeparator : "index.js"

238−

239−modulesDir :: FilePath

240−modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"

241−

242-- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the

118-- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the

243-- options and ignores the warning messages.

119-- options and ignores the warning messages.

244runMake :: P.Make a -> IO (Either P.MultipleErrors a)

120runMake :: P.Make a -> IO (Either P.MultipleErrors a)

@@ -258,6 +134,58 @@ make st@PSCiState{..} ms = P.make actions' (map snd loadedModules ++ ms)

258 loadedModules = psciLoadedModules st

134 loadedModules = psciLoadedModules st

259 allModules = map (first Right) loadedModules ++ map (Left P.RebuildAlways,) ms

135 allModules = map (first Right) loadedModules ++ map (Left P.RebuildAlways,) ms

260

136

137+

138+-- Commands

139+

140+-- |

141+-- Parses the input and returns either a Metacommand, or an error as a string.

142+--

143+getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command))

144+getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do

145+ firstLine <- withInterrupt $ getInputLine "> "

146+ case firstLine of

147+ Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty

148+ Just "" -> return (Right Nothing)

149+ Just s | singleLineMode || head s == ':' -> return .fmap Just $ parseCommand s

150+ Just s -> fmap Just . parseCommand <$> go [s]

151+ where

152+ go :: [String] -> InputT (StateT PSCiState IO) String

153+ go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " "

154+

155+-- |

156+-- Performs an action for each meta-command given, and also for expressions.

157+--

158+handleCommand :: Command -> PSCI ()

159+handleCommand (Expression val) = handleExpression val

160+handleCommand ShowHelp = PSCI $ outputStrLn helpMessage

161+handleCommand (Import im) = handleImport im

162+handleCommand (Decls l) = handleDecls l

163+handleCommand (LoadFile filePath) = PSCI $ whenFileExists filePath $ \absPath -> do

164+ m <- lift . lift $ loadModule absPath

165+ case m of

166+ Left err -> outputStrLn err

167+ Right mods -> lift $ modify (updateModules (map (absPath,) mods))

168+handleCommand (LoadForeign filePath) = PSCI $ whenFileExists filePath $ \absPath -> do

169+ foreignsOrError <- lift . lift . runMake $ do

170+ foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readFile absPath)

171+ P.parseForeignModulesFromFiles [(absPath, foreignFile)]

172+ case foreignsOrError of

173+ Left err -> outputStrLn $ P.prettyPrintMultipleErrors False err

174+ Right foreigns -> lift $ modify (updateForeignFiles foreigns)

175+handleCommand ResetState = do

176+ PSCI . lift . modify $ \st ->

177+ st { psciImportedModules = []

178+ , psciLetBindings = []

179+ }

180+ loadAllImportedModules

181+handleCommand (TypeOf val) = handleTypeOf val

182+handleCommand (KindOf typ) = handleKindOf typ

183+handleCommand (BrowseModule moduleName) = handleBrowse moduleName

184+handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules

185+handleCommand (ShowInfo QueryImport) = handleShowImportedModules

186+handleCommand QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug."

187+

188+

261-- |

189-- |

262-- Takes a value expression and evaluates it with the current state.

190-- Takes a value expression and evaluates it with the current state.

263--

191--

@@ -268,7 +196,7 @@ handleExpression val = do

268 let nodeArgs = psciNodeFlags st ++ [indexFile]

196 let nodeArgs = psciNodeFlags st ++ [indexFile]

269 e <- psciIO . runMake $ make st [supportModule, m]

197 e <- psciIO . runMake $ make st [supportModule, m]

270 case e of

198 case e of

271− Left errs -> printErrors errs

199+ Left errs -> PSCI $ printErrors errs

272 Right _ -> do

200 Right _ -> do

273 psciIO $ writeFile indexFile "require('$PSCI')['$main']();"

201 psciIO $ writeFile indexFile "require('$PSCI')['$main']();"

274 process <- psciIO findNodeProcess

202 process <- psciIO findNodeProcess

@@ -289,7 +217,7 @@ handleDecls ds = do

289 let m = createTemporaryModule False st' (P.ObjectLiteral [])

217 let m = createTemporaryModule False st' (P.ObjectLiteral [])

290 e <- psciIO . runMake $ make st' [m]

218 e <- psciIO . runMake $ make st' [m]

291 case e of

219 case e of

292− Left err -> printErrors err

220+ Left err -> PSCI $ printErrors err

293 Right _ -> PSCI $ lift (put st')

221 Right _ -> PSCI $ lift (put st')

294

222

295-- |

223-- |

@@ -344,7 +272,7 @@ handleImport im = do

344 let m = createTemporaryModuleForImports st

272 let m = createTemporaryModuleForImports st

345 e <- psciIO . runMake $ make st [m]

273 e <- psciIO . runMake $ make st [m]

346 case e of

274 case e of

347− Left errs -> printErrors errs

275+ Left errs -> PSCI $ printErrors errs

348 Right _ -> do

276 Right _ -> do

349 PSCI $ lift $ put st

277 PSCI $ lift $ put st

350 return ()

278 return ()

@@ -358,124 +286,12 @@ handleTypeOf val = do

358 let m = createTemporaryModule False st val

286 let m = createTemporaryModule False st val

359 e <- psciIO . runMake $ make st [m]

287 e <- psciIO . runMake $ make st [m]

360 case e of

288 case e of

361− Left errs -> printErrors errs

289+ Left errs -> PSCI $ printErrors errs

362 Right env' ->

290 Right env' ->

363 case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of

291 case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of

364 Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty

292 Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty

365 Nothing -> PSCI $ outputStrLn "Could not find type"

293 Nothing -> PSCI $ outputStrLn "Could not find type"

366

294

367−-- |

368−-- Pretty print a module's signatures

369−--

370−printModuleSignatures :: P.ModuleName -> P.Environment -> PSCI ()

371−printModuleSignatures moduleName (P.Environment {..}) =

372− PSCI $

373− -- get relevant components of a module from environment

374− let moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) names

375− moduleTypeClasses = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) typeClasses

376− moduleTypes = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) types

377−

378− in

379− -- print each component

380− (outputStr . unlines . map trimEnd . lines . Box.render . Box.vsep 1 Box.left)

381− [ printModule's (mapMaybe (showTypeClass . findTypeClass typeClasses)) moduleTypeClasses -- typeClasses

382− , printModule's (mapMaybe (showType typeClasses dataConstructors typeSynonyms . findType types)) moduleTypes -- types

383− , printModule's (map (showNameType . findNameType names)) moduleNamesIdent -- functions

384− ]

385−

386− where printModule's showF = Box.vsep 1 Box.left . showF

387−

388− findNameType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility))

389− findNameType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)

390−

391− showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box

392− showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType

393− showNameType _ = P.internalError "The impossible happened in printModuleSignatures."

394−

395− findTypeClass

396− :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])

397− -> P.Qualified (P.ProperName 'P.ClassName)

398− -> (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))

399− findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses)

400−

401− showTypeClass

402− :: (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))

403− -> Maybe Box.Box

404− showTypeClass (_, Nothing) = Nothing

405− showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) =

406− let constraints =

407− if null constrs

408− then Box.text ""

409− else Box.text "("

410− Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Qualified _ pn, lt) -> Box.text (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) constrs)

411− Box.<> Box.text ") <= "

412− className =

413− Box.text (P.runProperName name)

414− Box.<> Box.text (concatMap ((' ':) . fst) vars)

415− classBody =

416− Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) body)

417−

418− in

419− Just $

420− (Box.text "class "

421− Box.<> constraints

422− Box.<> className

423− Box.<+> if null body then Box.text "" else Box.text "where")

424− Box.// Box.moveRight 2 classBody

425−

426−

427− findType

428− :: M.Map (P.Qualified (P.ProperName 'P.TypeName)) (P.Kind, P.TypeKind)

429− -> P.Qualified (P.ProperName 'P.TypeName)

430− -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))

431− findType envTypes name = (name, M.lookup name envTypes)

432−

433− showType

434− :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])

435− -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident])

436− -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(String, Maybe P.Kind)], P.Type)

437− -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))

438− -> Maybe Box.Box

439− showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) =

440− case (typ, M.lookup n typeSynonymsEnv) of

441− (Just (_, P.TypeSynonym), Just (typevars, dtType)) ->

442− if M.member (fmap P.coerceProperName n) typeClassesEnv

443− then

444− Nothing

445− else

446− Just $

447− Box.text ("type " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars)

448− Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox dtType)

449−

450− (Just (_, P.DataType typevars pt), _) ->

451− let prefix =

452− case pt of

453− [(dtProperName,_)] ->

454− case M.lookup (P.Qualified modul dtProperName) dataConstructorsEnv of

455− Just (dataDeclType, _, _, _) -> P.showDataDeclType dataDeclType

456− _ -> "data"

457− _ -> "data"

458−

459− in

460− Just $ Box.text (prefix ++ " " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) Box.// printCons pt

461−

462− _ ->

463− Nothing

464−

465− where printCons pt =

466− Box.moveRight 2 $

467− Box.vcat Box.left $

468− mapFirstRest (Box.text "=" Box.<+>) (Box.text "|" Box.<+>) $

469− map (\(cons,idents) -> (Box.text (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt

470−

471− prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox t

472−

473− mapFirstRest _ _ [] = []

474− mapFirstRest f g (x:xs) = f x : map g xs

475−

476− trimEnd = reverse . dropWhile (== ' ') . reverse

477−

478−

479-- |

295-- |

480-- Browse a module and displays its signature (if module exists).

296-- Browse a module and displays its signature (if module exists).

481--

297--

@@ -484,14 +300,14 @@ handleBrowse moduleName = do

484 st <- PSCI $ lift get

300 st <- PSCI $ lift get

485 env <- psciIO . runMake $ make st []

301 env <- psciIO . runMake $ make st []

486 case env of

302 case env of

487− Left errs -> printErrors errs

303+ Left errs -> PSCI $ printErrors errs

488 Right env' ->

304 Right env' ->

489 if isModInEnv moduleName st

305 if isModInEnv moduleName st

490− then printModuleSignatures moduleName env'

306+ then PSCI $ printModuleSignatures moduleName env'

491 else case lookupUnQualifiedModName moduleName st of

307 else case lookupUnQualifiedModName moduleName st of

492 Just unQualifiedName ->

308 Just unQualifiedName ->

493 if isModInEnv unQualifiedName st

309 if isModInEnv unQualifiedName st

494− then printModuleSignatures unQualifiedName env'

310+ then PSCI $ printModuleSignatures unQualifiedName env'

495 else failNotInEnv moduleName

311 else failNotInEnv moduleName

496 Nothing ->

312 Nothing ->

497 failNotInEnv moduleName

313 failNotInEnv moduleName

@@ -503,10 +319,6 @@ handleBrowse moduleName = do

503 lookupUnQualifiedModName quaModName st =

319 lookupUnQualifiedModName quaModName st =

504 (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st)

320 (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st)

505

321

506−-- | Pretty-print errors

507−printErrors :: P.MultipleErrors -> PSCI ()

508−printErrors = PSCI . outputStrLn . P.prettyPrintMultipleErrors False

509−

510-- |

322-- |

511-- Takes a value and prints its kind

323-- Takes a value and prints its kind

512--

324--

@@ -517,7 +329,7 @@ handleKindOf typ = do

517 mName = P.ModuleName [P.ProperName "$PSCI"]

329 mName = P.ModuleName [P.ProperName "$PSCI"]

518 e <- psciIO . runMake $ make st [m]

330 e <- psciIO . runMake $ make st [m]

519 case e of

331 case e of

520− Left errs -> printErrors errs

332+ Left errs -> PSCI $ printErrors errs

521 Right env' ->

333 Right env' ->

522 case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of

334 case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of

523 Just (_, typ') -> do

335 Just (_, typ') -> do

@@ -531,63 +343,7 @@ handleKindOf typ = do

531 Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind

343 Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind

532 Nothing -> PSCI $ outputStrLn "Could not find kind"

344 Nothing -> PSCI $ outputStrLn "Could not find kind"

533

345

534−-- Commands

346+-- Misc

535−

536−-- |

537−-- Parses the input and returns either a Metacommand, or an error as a string.

538−--

539−getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command))

540−getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do

541− firstLine <- withInterrupt $ getInputLine "> "

542− case firstLine of

543− Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty

544− Just "" -> return (Right Nothing)

545− Just s | singleLineMode || head s == ':' -> return .fmap Just $ parseCommand s

546− Just s -> fmap Just . parseCommand <$> go [s]

547− where

548− go :: [String] -> InputT (StateT PSCiState IO) String

549− go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " "

550−

551−-- |

552−-- Performs an action for each meta-command given, and also for expressions.

553−--

554−handleCommand :: Command -> PSCI ()

555−handleCommand (Expression val) = handleExpression val

556−handleCommand ShowHelp = PSCI $ outputStrLn helpMessage

557−handleCommand (Import im) = handleImport im

558−handleCommand (Decls l) = handleDecls l

559−handleCommand (LoadFile filePath) = whenFileExists filePath $ \absPath -> do

560− m <- psciIO $ loadModule absPath

561− case m of

562− Left err -> PSCI $ outputStrLn err

563− Right mods -> PSCI . lift $ modify (updateModules (map (absPath,) mods))

564−handleCommand (LoadForeign filePath) = whenFileExists filePath $ \absPath -> do

565− foreignsOrError <- psciIO . runMake $ do

566− foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readFile absPath)

567− P.parseForeignModulesFromFiles [(absPath, foreignFile)]

568− case foreignsOrError of

569− Left err -> PSCI $ outputStrLn $ P.prettyPrintMultipleErrors False err

570− Right foreigns -> PSCI . lift $ modify (updateForeignFiles foreigns)

571−handleCommand ResetState = do

572− PSCI . lift . modify $ \st ->

573− st { psciImportedModules = []

574− , psciLetBindings = []

575− }

576− loadAllImportedModules

577−handleCommand (TypeOf val) = handleTypeOf val

578−handleCommand (KindOf typ) = handleKindOf typ

579−handleCommand (BrowseModule moduleName) = handleBrowse moduleName

580−handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules

581−handleCommand (ShowInfo QueryImport) = handleShowImportedModules

582−handleCommand QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug."

583−

584−whenFileExists :: FilePath -> (FilePath -> PSCI ()) -> PSCI ()

585−whenFileExists filePath f = do

586− absPath <- psciIO $ expandTilde filePath

587− exists <- psciIO $ doesFileExist absPath

588− if exists

589− then f absPath

590− else PSCI . outputStrLn $ "Couldn't locate: " ++ filePath

591

347

592-- |

348-- |

593-- Attempts to read initial commands from '.psci' in the present working

349-- Attempts to read initial commands from '.psci' in the present working

@@ -610,92 +366,6 @@ loadUserConfig = onFirstFileMatching readCommands pathGetters

610 else

366 else

611 return Nothing

367 return Nothing

612

368

613−

614-- | Checks if the Console module is defined

369-- | Checks if the Console module is defined

615consoleIsDefined :: [P.Module] -> Bool

370consoleIsDefined :: [P.Module] -> Bool

616consoleIsDefined = any ((== P.ModuleName (map P.ProperName [ "Control", "Monad", "Eff", "Console" ])) . P.getModuleName)

371consoleIsDefined = any ((== P.ModuleName (map P.ProperName [ "Control", "Monad", "Eff", "Console" ])) . P.getModuleName)

617−

618−-- |

619−-- The PSCI main loop.

620−--

621−loop :: PSCiOptions -> IO ()

622−loop PSCiOptions{..} = do

623− config <- loadUserConfig

624− inputFiles <- concat <$> traverse glob psciInputFile

625− foreignFiles <- concat <$> traverse glob psciForeignInputFiles

626− modulesOrFirstError <- loadAllModules inputFiles

627− case modulesOrFirstError of

628− Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure

629− Right modules -> do

630− historyFilename <- getHistoryFilename

631− let settings = defaultSettings { historyFile = Just historyFilename }

632− foreignsOrError <- runMake $ do

633− foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.ErrorMessage [] $ P.CannotReadFile inFile)) (readFile inFile))

634− P.parseForeignModulesFromFiles foreignFilesContent

635− case foreignsOrError of

636− Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure

637− Right foreigns ->

638− flip evalStateT (mkPSCiState [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do

639− outputStrLn prologueMessage

640− traverse_ (traverse_ (runPSCI . handleCommand)) config

641− modules' <- lift $ gets psciLoadedModules

642− unless (consoleIsDefined (map snd modules')) . outputStrLn $ unlines

643− [ "PSCi requires the purescript-console module to be installed."

644− , "For help getting started, visit http://wiki.purescript.org/PSCi"

645− ]

646− go

647− where

648− go :: InputT (StateT PSCiState IO) ()

649− go = do

650− c <- getCommand (not psciMultiLineMode)

651− case c of

652− Left err -> outputStrLn err >> go

653− Right Nothing -> go

654− Right (Just QuitPSCi) -> outputStrLn quitMessage

655− Right (Just c') -> do

656− handleInterrupt (outputStrLn "Interrupted.")

657− (withInterrupt (runPSCI (loadAllImportedModules >> handleCommand c')))

658− go

659−

660−multiLineMode :: Parser Bool

661−multiLineMode = switch $

662− long "multi-line-mode"

663− <> short 'm'

664− <> Opts.help "Run in multi-line mode (use ^D to terminate commands)"

665−

666−inputFile :: Parser FilePath

667−inputFile = strArgument $

668− metavar "FILE"

669− <> Opts.help "Optional .purs files to load on start"

670−

671−inputForeignFile :: Parser FilePath

672−inputForeignFile = strOption $

673− short 'f'

674− <> long "ffi"

675− <> help "The input .js file(s) providing foreign import implementations"

676−

677−nodeFlagsFlag :: Parser [String]

678−nodeFlagsFlag = option parser $

679− long "node-opts"

680− <> metavar "NODE_OPTS"

681− <> value []

682− <> Opts.help "Flags to pass to node, separated by spaces"

683− where

684− parser = words <$> str

685−

686−psciOptions :: Parser PSCiOptions

687−psciOptions = PSCiOptions <$> multiLineMode

688− <*> many inputFile

689− <*> many inputForeignFile

690− <*> nodeFlagsFlag

691−

692−runPSCi :: IO ()

693−runPSCi = execParser opts >>= loop

694− where

695− opts = info (version <*> helper <*> psciOptions) infoModList

696− infoModList = fullDesc <> headerInfo <> footerInfo

697− headerInfo = header "psci - Interactive mode for PureScript"

698− footerInfo = footer $ "psci " ++ showVersion Paths.version

699−

700− version :: Parser (a -> a)

701− version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> Opts.help "Show the version number" <> hidden

psci/Completion.hs → psci/PSCi/Completion.hsrenamed+3−3

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

1{-# LANGUAGE DataKinds #-}

2

3−module Completion where

3+module PSCi.Completion where

4

5import Prelude ()

6import Prelude.Compat

@@ -19,8 +19,8 @@ import System.Console.Haskeline

19import qualified Language.PureScript as P

20import qualified Language.PureScript.Names as N

21

22−import qualified Directive as D

22+import qualified PSCi.Directive as D

23−import Types

23+import PSCi.Types

24

25-- Completions may read the state, but not modify it.

26type CompletionM = ReaderT PSCiState IO

psci/Directive.hs → psci/PSCi/Directive.hsrenamed+6−2

@@ -13,13 +13,17 @@

13--

14-----------------------------------------------------------------------------

15

16−module Directive where

16+module PSCi.Directive where

17+

18+import Prelude ()

19+import Prelude.Compat

20+

17

21

18import Data.Maybe (fromJust, listToMaybe)

22import Data.Maybe (fromJust, listToMaybe)

19import Data.List (isPrefixOf)

23import Data.List (isPrefixOf)

20import Data.Tuple (swap)

24import Data.Tuple (swap)

21

25

22−import Types

26+import PSCi.Types

23

27

24-- |

28-- |

25-- List of all avaliable directives.

29-- List of all avaliable directives.

psci/PSCi/IO.hsnew file+68

@@ -0,0 +1,68 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : IO

5+-- License : MIT

6+--

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

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module PSCi.IO where

16+

17+import Prelude ()

18+import Prelude.Compat

19+

20+import System.Directory (createDirectoryIfMissing, getHomeDirectory, findExecutable, doesFileExist)

21+import System.FilePath (takeDirectory, (</>), isPathSeparator)

22+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

23+import Control.Monad (msum)

24+import Control.Monad.IO.Class (MonadIO, liftIO)

25+import System.Console.Haskeline (outputStrLn, InputT)

26+

27+mkdirp :: FilePath -> IO ()

28+mkdirp = createDirectoryIfMissing True . takeDirectory

29+

30+-- File helpers

31+

32+onFirstFileMatching :: Monad m => (b -> m (Maybe a)) -> [b] -> m (Maybe a)

33+onFirstFileMatching f pathVariants = runMaybeT . msum $ map (MaybeT . f) pathVariants

34+

35+-- |

36+-- Locates the node executable.

37+-- Checks for either @nodejs@ or @node@.

38+--

39+findNodeProcess :: IO (Maybe String)

40+findNodeProcess = onFirstFileMatching findExecutable names

41+ where names = ["nodejs", "node"]

42+

43+-- |

44+-- Grabs the filename where the history is stored.

45+--

46+getHistoryFilename :: IO FilePath

47+getHistoryFilename = do

48+ home <- getHomeDirectory

49+ let filename = home </> ".purescript" </> "psci_history"

50+ mkdirp filename

51+ return filename

52+

53+

54+-- |

55+-- Expands tilde in path.

56+--

57+expandTilde :: FilePath -> IO FilePath

58+expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory

59+expandTilde p = return p

60+

61+

62+whenFileExists :: MonadIO m => FilePath -> (FilePath -> InputT m ()) -> InputT m ()

63+whenFileExists filePath f = do

64+ absPath <- liftIO $ expandTilde filePath

65+ exists <- liftIO $ doesFileExist absPath

66+ if exists

67+ then f absPath

68+ else outputStrLn $ "Couldn't locate: " ++ filePath

psci/PSCi/Message.hsnew file+53

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

1+module PSCi.Message where

2+

3+

4+import Data.List (intercalate)

5+import qualified PSCi.Directive as D

6+import PSCi.Types

7+

8+-- Messages

9+

10+-- |

11+-- The help message.

12+--

13+helpMessage :: String

14+helpMessage = "The following commands are available:\n\n " ++

15+ intercalate "\n " (map line D.help) ++

16+ "\n\n" ++ extraHelp

17+ where

18+ line :: (Directive, String, String) -> String

19+ line (dir, arg, desc) =

20+ let cmd = ':' : D.stringFor dir

21+ in unwords [ cmd

22+ , replicate (11 - length cmd) ' '

23+ , arg

24+ , replicate (11 - length arg) ' '

25+ , desc

26+ ]

27+

28+ extraHelp =

29+ "Further information is available on the PureScript wiki:\n" ++

30+ " --> https://github.com/purescript/purescript/wiki/psci"

31+

32+

33+-- |

34+-- The welcome prologue.

35+--

36+prologueMessage :: String

37+prologueMessage = intercalate "\n"

38+ [ " ____ ____ _ _ "

39+ , "| _ \\ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_ "

40+ , "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|"

41+ , "| __/| |_| | | | __/___) | (__| | | | |_) | |_ "

42+ , "|_| \\__,_|_| \\___|____/ \\___|_| |_| .__/ \\__|"

43+ , " |_| "

44+ , ""

45+ , ":? shows help"

46+ ]

47+

48+-- |

49+-- The quit message.

50+--

51+quitMessage :: String

52+quitMessage = "See ya!"

53+

psci/PSCi/Module.hsnew file+106

@@ -0,0 +1,106 @@

1+module PSCi.Module where

2+

3+import Prelude ()

4+import Prelude.Compat

5+

6+import qualified Language.PureScript as P

7+import PSCi.Types

8+import System.FilePath (pathSeparator)

9+import Control.Monad

10+

11+-- | The name of the PSCI support module

12+supportModuleName :: P.ModuleName

13+supportModuleName = P.ModuleName [P.ProperName "$PSCI", P.ProperName "Support"]

14+

15+-- | Support module, contains code to evaluate terms

16+supportModule :: P.Module

17+supportModule =

18+ case P.parseModulesFromFiles id [("", code)] of

19+ Right [(_, P.Module ss cs _ ds exps)] -> P.Module ss cs supportModuleName ds exps

20+ _ -> P.internalError "Support module could not be parsed"

21+ where

22+ code :: String

23+ code = unlines

24+ [ "module S where"

25+ , ""

26+ , "import Prelude"

27+ , "import Control.Monad.Eff"

28+ , "import Control.Monad.Eff.Console"

29+ , "import Control.Monad.Eff.Unsafe"

30+ , ""

31+ , "class Eval a where"

32+ , " eval :: a -> Eff (console :: CONSOLE) Unit"

33+ , ""

34+ , "instance evalShow :: (Show a) => Eval a where"

35+ , " eval = print"

36+ , ""

37+ , "instance evalEff :: (Eval a) => Eval (Eff eff a) where"

38+ , " eval x = unsafeInterleaveEff x >>= eval"

39+ ]

40+

41+-- Module Management

42+

43+-- |

44+-- Loads a file for use with imports.

45+--

46+loadModule :: FilePath -> IO (Either String [P.Module])

47+loadModule filename = do

48+ content <- readFile filename

49+ return $ either (Left . P.prettyPrintMultipleErrors False) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]

50+

51+-- |

52+-- Load all modules.

53+--

54+loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)])

55+loadAllModules files = do

56+ filesAndContent <- forM files $ \filename -> do

57+ content <- readFile filename

58+ return (filename, content)

59+ return $ P.parseModulesFromFiles id filesAndContent

60+

61+

62+-- |

63+-- Makes a volatile module to execute the current expression.

64+--

65+createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module

66+createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindings = lets} val =

67+ let

68+ moduleName = P.ModuleName [P.ProperName "$PSCI"]

69+ trace = P.Var (P.Qualified (Just supportModuleName) (P.Ident "eval"))

70+ mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))

71+ itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val

72+ mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] $ Right mainValue

73+ decls = if exec then [itDecl, mainDecl] else [itDecl]

74+ in

75+ P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing

76+

77+

78+-- |

79+-- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration.

80+--

81+createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module

82+createTemporaryModuleForKind PSCiState{psciImportedModules = imports, psciLetBindings = lets} typ =

83+ let

84+ moduleName = P.ModuleName [P.ProperName "$PSCI"]

85+ itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ

86+ in

87+ P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing

88+

89+-- |

90+-- Makes a volatile module to execute the current imports.

91+--

92+createTemporaryModuleForImports :: PSCiState -> P.Module

93+createTemporaryModuleForImports PSCiState{psciImportedModules = imports} =

94+ let

95+ moduleName = P.ModuleName [P.ProperName "$PSCI"]

96+ in

97+ P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName (importDecl `map` imports) Nothing

98+

99+importDecl :: ImportedModule -> P.Declaration

100+importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ False

101+

102+indexFile :: FilePath

103+indexFile = ".psci_modules" ++ pathSeparator : "index.js"

104+

105+modulesDir :: FilePath

106+modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"

psci/PSCi/Option.hsnew file+57

@@ -0,0 +1,57 @@

1+module PSCi.Option (

2+ getOpt

3+) where

4+

5+import Prelude ()

6+import Prelude.Compat

7+

8+import Options.Applicative as Opts

9+import Data.Version (showVersion)

10+

11+import PSCi.Types

12+import qualified Paths_purescript as Paths

13+

14+-- Parse Command line option

15+

16+multiLineMode :: Parser Bool

17+multiLineMode = switch $

18+ long "multi-line-mode"

19+ <> short 'm'

20+ <> Opts.help "Run in multi-line mode (use ^D to terminate commands)"

21+

22+inputFile :: Parser FilePath

23+inputFile = strArgument $

24+ metavar "FILE"

25+ <> Opts.help "Optional .purs files to load on start"

26+

27+inputForeignFile :: Parser FilePath

28+inputForeignFile = strOption $

29+ short 'f'

30+ <> long "ffi"

31+ <> help "The input .js file(s) providing foreign import implementations"

32+

33+nodeFlagsFlag :: Parser [String]

34+nodeFlagsFlag = option parser $

35+ long "node-opts"

36+ <> metavar "NODE_OPTS"

37+ <> value []

38+ <> Opts.help "Flags to pass to node, separated by spaces"

39+ where

40+ parser = words <$> str

41+

42+psciOptions :: Parser PSCiOptions

43+psciOptions = PSCiOptions <$> multiLineMode

44+ <*> many inputFile

45+ <*> many inputForeignFile

46+ <*> nodeFlagsFlag

47+

48+version :: Parser (a -> a)

49+version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> Opts.help "Show the version number" <> hidden

50+

51+getOpt :: IO PSCiOptions

52+getOpt = execParser opts

53+ where

54+ opts = info (version <*> helper <*> psciOptions) infoModList

55+ infoModList = fullDesc <> headerInfo <> footerInfo

56+ headerInfo = header "psci - Interactive mode for PureScript"

57+ footerInfo = footer $ "psci " ++ showVersion Paths.version

psci/Parser.hs → psci/PSCi/Parser.hsrenamed+3−3

@@ -13,7 +13,7 @@

13--

14-----------------------------------------------------------------------------

15

16−module Parser

16+module PSCi.Parser

17 ( parseCommand

18 ) where

19

@@ -28,8 +28,8 @@ import Text.Parsec hiding ((<|>))

28import qualified Language.PureScript as P

29import Language.PureScript.Parser.Common (mark, same)

30

31−import qualified Directive as D

31+import qualified PSCi.Directive as D

32−import Types

32+import PSCi.Types

33

34-- |

35-- Parses PSCI metacommands or expressions input from the user.

psci/PSCi/Printer.hsnew file+131

@@ -0,0 +1,131 @@

1+{-# LANGUAGE RecordWildCards #-}

2+{-# LANGUAGE DataKinds #-}

3+

4+module PSCi.Printer where

5+

6+import Prelude ()

7+import Prelude.Compat

8+

9+import qualified Language.PureScript as P

10+import qualified Text.PrettyPrint.Boxes as Box

11+import qualified Data.Map as M

12+import System.Console.Haskeline

13+import Data.Maybe (mapMaybe)

14+import Data.List (intersperse)

15+import Control.Monad.IO.Class (MonadIO)

16+

17+-- Printers

18+

19+-- |

20+-- Pretty print a module's signatures

21+--

22+printModuleSignatures :: MonadIO m => P.ModuleName -> P.Environment -> InputT m ()

23+printModuleSignatures moduleName (P.Environment {..}) =

24+ -- get relevant components of a module from environment

25+ let moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) names

26+ moduleTypeClasses = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) typeClasses

27+ moduleTypes = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) types

28+

29+ in

30+ -- print each component

31+ (outputStr . unlines . map trimEnd . lines . Box.render . Box.vsep 1 Box.left)

32+ [ printModule's (mapMaybe (showTypeClass . findTypeClass typeClasses)) moduleTypeClasses -- typeClasses

33+ , printModule's (mapMaybe (showType typeClasses dataConstructors typeSynonyms . findType types)) moduleTypes -- types

34+ , printModule's (map (showNameType . findNameType names)) moduleNamesIdent -- functions

35+ ]

36+

37+ where printModule's showF = Box.vsep 1 Box.left . showF

38+

39+ findNameType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility))

40+ findNameType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)

41+

42+ showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box

43+ showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType

44+ showNameType _ = P.internalError "The impossible happened in printModuleSignatures."

45+

46+ findTypeClass

47+ :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])

48+ -> P.Qualified (P.ProperName 'P.ClassName)

49+ -> (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))

50+ findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses)

51+

52+ showTypeClass

53+ :: (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))

54+ -> Maybe Box.Box

55+ showTypeClass (_, Nothing) = Nothing

56+ showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) =

57+ let constraints =

58+ if null constrs

59+ then Box.text ""

60+ else Box.text "("

61+ Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Qualified _ pn, lt) -> Box.text (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) constrs)

62+ Box.<> Box.text ") <= "

63+ className =

64+ Box.text (P.runProperName name)

65+ Box.<> Box.text (concatMap ((' ':) . fst) vars)

66+ classBody =

67+ Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) body)

68+

69+ in

70+ Just $

71+ (Box.text "class "

72+ Box.<> constraints

73+ Box.<> className

74+ Box.<+> if null body then Box.text "" else Box.text "where")

75+ Box.// Box.moveRight 2 classBody

76+

77+

78+ findType

79+ :: M.Map (P.Qualified (P.ProperName 'P.TypeName)) (P.Kind, P.TypeKind)

80+ -> P.Qualified (P.ProperName 'P.TypeName)

81+ -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))

82+ findType envTypes name = (name, M.lookup name envTypes)

83+

84+ showType

85+ :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])

86+ -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident])

87+ -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(String, Maybe P.Kind)], P.Type)

88+ -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))

89+ -> Maybe Box.Box

90+ showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) =

91+ case (typ, M.lookup n typeSynonymsEnv) of

92+ (Just (_, P.TypeSynonym), Just (typevars, dtType)) ->

93+ if M.member (fmap P.coerceProperName n) typeClassesEnv

94+ then

95+ Nothing

96+ else

97+ Just $

98+ Box.text ("type " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars)

99+ Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox dtType)

100+

101+ (Just (_, P.DataType typevars pt), _) ->

102+ let prefix =

103+ case pt of

104+ [(dtProperName,_)] ->

105+ case M.lookup (P.Qualified modul dtProperName) dataConstructorsEnv of

106+ Just (dataDeclType, _, _, _) -> P.showDataDeclType dataDeclType

107+ _ -> "data"

108+ _ -> "data"

109+

110+ in

111+ Just $ Box.text (prefix ++ " " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) Box.// printCons pt

112+

113+ _ ->

114+ Nothing

115+

116+ where printCons pt =

117+ Box.moveRight 2 $

118+ Box.vcat Box.left $

119+ mapFirstRest (Box.text "=" Box.<+>) (Box.text "|" Box.<+>) $

120+ map (\(cons,idents) -> (Box.text (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt

121+

122+ prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox t

123+

124+ mapFirstRest _ _ [] = []

125+ mapFirstRest f g (x:xs) = f x : map g xs

126+

127+ trimEnd = reverse . dropWhile (== ' ') . reverse

128+

129+-- | Pretty-print errors

130+printErrors :: MonadIO m => P.MultipleErrors -> InputT m ()

131+printErrors = outputStrLn . P.prettyPrintMultipleErrors False

psci/Types.hs → psci/PSCi/Types.hsrenamed+4−1

@@ -13,7 +13,10 @@

13--

14-----------------------------------------------------------------------------

15

16−module Types where

16+module PSCi.Types where

17+

18+import Prelude ()

19+import Prelude.Compat

17

20

18import Control.Arrow (second)

21import Control.Arrow (second)

19import Data.Map (Map)

22import Data.Map (Map)

purescript.cabal+40−32

@@ -16,7 +16,7 @@ author: Phil Freeman <paf31@cantab.net>,

16 Hardy Jones <jones3.hardy@gmail.com>,

17 Harry Garrood <harry@garrood.me>

18

19−tested-with: GHC==7.8

19+tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.1

20

21extra-source-files: examples/passing/*.purs

22 , examples/failing/*.purs

@@ -27,7 +27,13 @@ extra-source-files: examples/passing/*.purs

27 , tests/support/package.json

28 , tests/support/bower.json

29 , tests/support/setup-win.cmd

30− , psci/tests/data/Sample.purs

30+ , tests/support/flattened/*.purs

31+ , tests/support/flattened/*.js

32+ , tests/support/psci/*.purs

33+ , tests/support/prelude/bower.json

34+ , tests/support/prelude/src/*.purs

35+ , tests/support/prelude/src/*.js

36+ , tests/support/prelude/LICENSE

31 , stack.yaml

37 , stack.yaml

32 , stack-lts-2.yaml

38 , stack-lts-2.yaml

33 , stack-lts-3.yaml

39 , stack-lts-3.yaml

@@ -55,13 +61,13 @@ library

55 filepath -any,

61 filepath -any,

56 mtl >= 2.1.0 && < 2.3.0,

62 mtl >= 2.1.0 && < 2.3.0,

57 parsec -any,

63 parsec -any,

58− transformers >= 0.3.0 && < 0.5,

64+ transformers >= 0.3.0 && < 0.6,

59 transformers-compat >= 0.3.0,

65 transformers-compat >= 0.3.0,

60 utf8-string >= 1 && < 2,

66 utf8-string >= 1 && < 2,

61 pattern-arrows >= 0.0.2 && < 0.1,

67 pattern-arrows >= 0.0.2 && < 0.1,

62 time -any,

68 time -any,

63 boxes >= 0.1.4 && < 0.2.0,

69 boxes >= 0.1.4 && < 0.2.0,

64− aeson >= 0.8 && < 0.11,

70+ aeson >= 0.8 && < 0.12,

65 vector -any,

71 vector -any,

66 bower-json >= 0.7,

72 bower-json >= 0.7,

67 aeson-better-errors >= 0.8,

73 aeson-better-errors >= 0.8,

@@ -71,7 +77,7 @@ library

71 language-javascript == 0.5.*,

77 language-javascript == 0.5.*,

72 syb -any,

78 syb -any,

73 Glob >= 0.7 && < 0.8,

79 Glob >= 0.7 && < 0.8,

74− process >= 1.2.0 && < 1.4,

80+ process >= 1.2.0 && < 1.5,

75 safe >= 0.3.9 && < 0.4,

81 safe >= 0.3.9 && < 0.4,

76 semigroups >= 0.16.2 && < 0.19,

82 semigroups >= 0.16.2 && < 0.19,

77 parallel >= 3.2 && < 3.3

83 parallel >= 3.2 && < 3.3

@@ -159,6 +165,9 @@ library

159 Language.PureScript.Sugar.Names.Exports

165 Language.PureScript.Sugar.Names.Exports

160 Language.PureScript.Sugar.ObjectWildcards

166 Language.PureScript.Sugar.ObjectWildcards

161 Language.PureScript.Sugar.Operators

167 Language.PureScript.Sugar.Operators

168+ Language.PureScript.Sugar.Operators.Common

169+ Language.PureScript.Sugar.Operators.Expr

170+ Language.PureScript.Sugar.Operators.Binders

162 Language.PureScript.Sugar.TypeClasses

171 Language.PureScript.Sugar.TypeClasses

163 Language.PureScript.Sugar.TypeClasses.Deriving

172 Language.PureScript.Sugar.TypeClasses.Deriving

164 Language.PureScript.Sugar.TypeDeclarations

173 Language.PureScript.Sugar.TypeDeclarations

@@ -186,7 +195,7 @@ library

186 Language.PureScript.Docs.RenderedCode.Types

195 Language.PureScript.Docs.RenderedCode.Types

187 Language.PureScript.Docs.RenderedCode.Render

196 Language.PureScript.Docs.RenderedCode.Render

188 Language.PureScript.Docs.AsMarkdown

197 Language.PureScript.Docs.AsMarkdown

189− Language.PureScript.Docs.ParseAndDesugar

198+ Language.PureScript.Docs.ParseAndBookmark

190 Language.PureScript.Docs.Utils.MonoidExtras

199 Language.PureScript.Docs.Utils.MonoidExtras

191

200

192 Language.PureScript.Publish

201 Language.PureScript.Publish

@@ -212,11 +221,11 @@ executable psc

212 containers -any, directory -any, filepath -any,

221 containers -any, directory -any, filepath -any,

213 mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,

222 mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,

214 time -any, transformers -any, transformers-compat -any, Glob >= 0.7 && < 0.8,

223 time -any, transformers -any, transformers-compat -any, Glob >= 0.7 && < 0.8,

215− aeson >= 0.8 && < 0.11, bytestring -any, utf8-string >= 1 && < 2

224+ aeson >= 0.8 && < 0.12, bytestring -any, utf8-string >= 1 && < 2

216 main-is: Main.hs

225 main-is: Main.hs

217 buildable: True

226 buildable: True

218 hs-source-dirs: psc

227 hs-source-dirs: psc

219− other-modules: JSON

228+ other-modules: JSON, Paths_purescript

220 ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N"

229 ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N"

221

230

222executable psci

231executable psci

@@ -229,12 +238,17 @@ executable psci

229 main-is: Main.hs

238 main-is: Main.hs

230 buildable: True

239 buildable: True

231 hs-source-dirs: psci psci/main

240 hs-source-dirs: psci psci/main

232− other-modules: Types

241+ other-modules: PSCi

242+ PSCi.Types

233− Parser

243+ PSCi.Parser

234− Directive

244+ PSCi.Directive

235− Completion

245+ PSCi.Completion

236− PSCi

246+ PSCi.IO

237− IO

247+ PSCi.Message

248+ PSCi.Option

249+ PSCi.Module

250+ PSCi.Printer

251+ Paths_purescript

238 ghc-options: -Wall -O2

252 ghc-options: -Wall -O2

239

253

240executable psc-docs

254executable psc-docs

@@ -244,6 +258,7 @@ executable psc-docs

244 filepath -any, Glob -any, transformers -any,

258 filepath -any, Glob -any, transformers -any,

245 transformers-compat -any

259 transformers-compat -any

246 main-is: Main.hs

260 main-is: Main.hs

261+ other-modules: Paths_purescript

247 buildable: True

262 buildable: True

248 hs-source-dirs: psc-docs

263 hs-source-dirs: psc-docs

249 other-modules: Ctags

264 other-modules: Ctags

@@ -254,6 +269,7 @@ executable psc-docs

254executable psc-publish

269executable psc-publish

255 build-depends: base >=4 && <5, purescript -any, bytestring -any, aeson -any, optparse-applicative -any

270 build-depends: base >=4 && <5, purescript -any, bytestring -any, aeson -any, optparse-applicative -any

256 main-is: Main.hs

271 main-is: Main.hs

272+ other-modules: Paths_purescript

257 buildable: True

273 buildable: True

258 hs-source-dirs: psc-publish

274 hs-source-dirs: psc-publish

259 ghc-options: -Wall -O2

275 ghc-options: -Wall -O2

@@ -263,6 +279,7 @@ executable psc-hierarchy

263 process -any, mtl -any, parsec -any, filepath -any, directory -any,

279 process -any, mtl -any, parsec -any, filepath -any, directory -any,

264 Glob -any

280 Glob -any

265 main-is: Main.hs

281 main-is: Main.hs

282+ other-modules: Paths_purescript

266 buildable: True

283 buildable: True

267 hs-source-dirs: hierarchy

284 hs-source-dirs: hierarchy

268 other-modules:

285 other-modules:

@@ -270,7 +287,7 @@ executable psc-hierarchy

270

287

271executable psc-bundle

288executable psc-bundle

272 main-is: Main.hs

289 main-is: Main.hs

273− other-modules:

290+ other-modules: Paths_purescript

274 other-extensions:

291 other-extensions:

275 build-depends: base >=4 && <5,

292 build-depends: base >=4 && <5,

276 purescript -any,

293 purescript -any,

@@ -301,27 +318,18 @@ test-suite tests

301 filepath -any, mtl -any, parsec -any, purescript -any,

318 filepath -any, mtl -any, parsec -any, purescript -any,

302 transformers -any, process -any, transformers-compat -any, time -any,

319 transformers -any, process -any, transformers-compat -any, time -any,

303 Glob -any, aeson-better-errors -any, bytestring -any, aeson -any,

320 Glob -any, aeson-better-errors -any, bytestring -any, aeson -any,

304− base-compat -any

321+ base-compat -any, haskeline >= 0.7.0.0, optparse-applicative -any,

322+ boxes -any, HUnit -any

323+ ghc-options: -Wall

305 type: exitcode-stdio-1.0

324 type: exitcode-stdio-1.0

306 main-is: Main.hs

325 main-is: Main.hs

307− other-modules: TestsSetup

326+ other-modules: TestUtils

308− TestPscPublish

327+ TestCompiler

309 TestDocs

328 TestDocs

329+ TestPscPublish

330+ TestPsci

310 buildable: True

331 buildable: True

311− hs-source-dirs: tests tests/common

332+ hs-source-dirs: tests psci

312−

313−test-suite psci-tests

314− build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,

315− mtl -any, optparse-applicative >= 0.10.0, parsec -any,

316− haskeline >= 0.7.0.0, purescript -any, transformers -any,

317− transformers-compat -any, process -any, HUnit -any, time -any,

318− Glob -any, base-compat >=0.6.0, boxes >= 0.1.4 && < 0.2.0

319− type: exitcode-stdio-1.0

320− main-is: Main.hs

321− other-modules: TestsSetup

322− buildable: True

323− hs-source-dirs: psci psci/tests tests/common

324− ghc-options: -Wall

325

333

326test-suite pcc-tests

334test-suite pcc-tests

327 build-depends: base >=4 && <5, directory -any, filepath -any, process -any

335 build-depends: base >=4 && <5, directory -any, filepath -any, process -any

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+8−11

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

@@ -337,6 +337,9 @@ data Expr

337 -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor

338 -- will be removed.

339 --

340+ -- Note: although it seems this constructor is not used, it _is_ useful, since it prevents

341+ -- certain traversals from matching.

342+ --

340 | Parens Expr

343 | Parens Expr

341 -- |

344 -- |

342 -- Operator section. This will be removed during desugaring and replaced with a partially applied

345 -- Operator section. This will be removed during desugaring and replaced with a partially applied

@@ -352,11 +355,6 @@ data Expr

352 --

355 --

353 | ObjectLiteral [(String, Expr)]

356 | ObjectLiteral [(String, Expr)]

354 -- |

357 -- |

355− -- An object constructor (object literal with underscores). This will be removed during

356− -- desugaring and expanded into a lambda that returns an object literal.

357− --

358− | ObjectConstructor [(String, Maybe Expr)]

359− -- |

360 -- An object property getter (e.g. `_.x`). This will be removed during

358 -- An object property getter (e.g. `_.x`). This will be removed during

361 -- desugaring and expanded into a lambda that reads a property from an object.

359 -- desugaring and expanded into a lambda that reads a property from an object.

362 --

360 --

@@ -370,11 +368,6 @@ data Expr

370 --

368 --

371 | ObjectUpdate Expr [(String, Expr)]

369 | ObjectUpdate Expr [(String, Expr)]

372 -- |

370 -- |

373− -- Partial record updater. This will be removed during desugaring and

374− -- expanded into a lambda that returns an object update.

375− --

376− | ObjectUpdater (Maybe Expr) [(String, Maybe Expr)]

377− -- |

378 -- Function introduction

371 -- Function introduction

379 --

372 --

380 | Abs (Either Ident Binder) Expr

373 | Abs (Either Ident Binder) Expr

@@ -433,6 +426,10 @@ data Expr

433 --

426 --

434 | SuperClassDictionary (Qualified (ProperName 'ClassName)) [Type]

427 | SuperClassDictionary (Qualified (ProperName 'ClassName)) [Type]

435 -- |

428 -- |

429+ -- A placeholder for an anonymous function argument

430+ --

431+ | AnonymousArgument

432+ -- |

436 -- A value with source position information

433 -- A value with source position information

437 --

434 --

438 | PositionedValue SourceSpan [Comment] Expr

435 | PositionedValue SourceSpan [Comment] Expr

src/Language/PureScript/AST/Traversals.hs+16−18

@@ -23,7 +23,7 @@ import Data.Foldable (fold)

23import qualified Data.Set as S

24

25import Control.Monad

26−import Control.Arrow ((***), (+++), second)

26+import Control.Arrow ((***), (+++))

27

28import Language.PureScript.AST.Binders

29import Language.PureScript.AST.Declarations

@@ -54,11 +54,9 @@ everywhereOnValues f g h = (f', g', h')

54 g' (OperatorSection op (Right v)) = g (OperatorSection (g' op) (Right $ g' v))

55 g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))

56 g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))

57− g' (ObjectConstructor vs) = g (ObjectConstructor (map (second (fmap g')) vs))

58 g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))

57 g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))

59 g' (Accessor prop v) = g (Accessor prop (g' v))

58 g' (Accessor prop v) = g (Accessor prop (g' v))

60 g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))

59 g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))

61− g' (ObjectUpdater obj vs) = g (ObjectUpdater (fmap g' obj) (map (second (fmap g')) vs))

62 g' (Abs name v) = g (Abs name (g' v))

60 g' (Abs name v) = g (Abs name (g' v))

63 g' (App v1 v2) = g (App (g' v1) (g' v2))

61 g' (App v1 v2) = g (App (g' v1) (g' v2))

64 g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3))

62 g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3))

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

71

69

72 h' :: Binder -> Binder

70 h' :: Binder -> Binder

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

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

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

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

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

@@ -112,11 +112,9 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

112 g' (OperatorSection op (Right v)) = OperatorSection <$> (g op >>= g') <*> (Right <$> (g v >>= g'))

113 g' (ArrayLiteral vs) = ArrayLiteral <$> traverse (g' <=< g) vs

114 g' (ObjectLiteral vs) = ObjectLiteral <$> traverse (sndM (g' <=< g)) vs

115− g' (ObjectConstructor vs) = ObjectConstructor <$> traverse (sndM $ maybeM (g' <=< g)) vs

116 g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')

115 g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')

117 g' (Accessor prop v) = Accessor prop <$> (g v >>= g')

116 g' (Accessor prop v) = Accessor prop <$> (g v >>= g')

118 g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs

117 g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs

119− g' (ObjectUpdater obj vs) = ObjectUpdater <$> (maybeM g obj >>= maybeM g') <*> traverse (sndM $ maybeM (g' <=< g)) vs

120 g' (Abs name v) = Abs name <$> (g v >>= g')

118 g' (Abs name v) = Abs name <$> (g v >>= g')

121 g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g')

119 g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g')

122 g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g')

120 g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g')

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

128 g' other = g other

126 g' other = g other

129

127

130 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')

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

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

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

@@ -165,11 +165,9 @@ everywhereOnValuesM f g h = (f', g', h')

165 g' (OperatorSection op (Right v)) = (OperatorSection <$> g' op <*> (Right <$> g' v)) >>= g

166 g' (ArrayLiteral vs) = (ArrayLiteral <$> traverse g' vs) >>= g

167 g' (ObjectLiteral vs) = (ObjectLiteral <$> traverse (sndM g') vs) >>= g

168− g' (ObjectConstructor vs) = (ObjectConstructor <$> traverse (sndM $ maybeM g') vs) >>= g

169 g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g

168 g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g

170 g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g

169 g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g

171 g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g

170 g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g

172− g' (ObjectUpdater obj vs) = (ObjectUpdater <$> maybeM g' obj <*> traverse (sndM $ maybeM g') vs) >>= g

173 g' (Abs name v) = (Abs name <$> g' v) >>= g

171 g' (Abs name v) = (Abs name <$> g' v) >>= g

174 g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g

172 g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g

175 g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g

173 g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g

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

181 g' other = g other

179 g' other = g other

182

180

183 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

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

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

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

@@ -221,11 +221,9 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')

221 g' v@(OperatorSection op (Right v1)) = g v <> g' op <> g' v1

222 g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)

223 g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)

224− g' v@(ObjectConstructor vs) = foldl (<>) (g v) (map g' (mapMaybe snd vs))

225 g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1

224 g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1

226 g' v@(Accessor _ v1) = g v <> g' v1

225 g' v@(Accessor _ v1) = g v <> g' v1

227 g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)

226 g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)

228− g' v@(ObjectUpdater obj vs) = foldl (<>) (maybe (g v) (\x -> g v <> g' x) obj) (map g' (mapMaybe snd vs))

229 g' v@(Abs _ v1) = g v <> g' v1

227 g' v@(Abs _ v1) = g v <> g' v1

230 g' v@(App v1 v2) = g v <> g' v1 <> g' v2

228 g' v@(App v1 v2) = g v <> g' v1 <> g' v2

231 g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3

229 g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3

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

237 g' v = g v

235 g' v = g v

238

236

239 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

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

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

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

@@ -288,11 +288,9 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'

288 g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v

289 g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)

290 g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)

291− g' s (ObjectConstructor vs) = foldl (<>) r0 (map (g'' s) (mapMaybe snd vs))

292 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1

291 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1

293 g' s (Accessor _ v1) = g'' s v1

292 g' s (Accessor _ v1) = g'' s v1

294 g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)

293 g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)

295− g' s (ObjectUpdater obj vs) = foldl (<>) (maybe r0 (g'' s) obj) (map (g'' s) (mapMaybe snd vs))

296 g' s (Abs _ v1) = g'' s v1

294 g' s (Abs _ v1) = g'' s v1

297 g' s (App v1 v2) = g'' s v1 <> g'' s v2

295 g' s (App v1 v2) = g'' s v1 <> g'' s v2

298 g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3

296 g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3

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

306 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

307

305

308 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

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

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

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

@@ -358,11 +358,9 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

358 g' s (OperatorSection op (Right v)) = OperatorSection <$> g'' s op <*> (Right <$> g'' s v)

359 g' s (ArrayLiteral vs) = ArrayLiteral <$> traverse (g'' s) vs

360 g' s (ObjectLiteral vs) = ObjectLiteral <$> traverse (sndM (g'' s)) vs

361− g' s (ObjectConstructor vs) = ObjectConstructor <$> traverse (sndM $ maybeM (g'' s)) vs

362 g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v

361 g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v

363 g' s (Accessor prop v) = Accessor prop <$> g'' s v

362 g' s (Accessor prop v) = Accessor prop <$> g'' s v

364 g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs

363 g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs

365− g' s (ObjectUpdater obj vs) = ObjectUpdater <$> maybeM (g'' s) obj <*> traverse (sndM $ maybeM (g'' s)) vs

366 g' s (Abs name v) = Abs name <$> g'' s v

364 g' s (Abs name v) = Abs name <$> g'' s v

367 g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2

365 g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2

368 g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3

366 g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3

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

376 h'' s = uncurry h' <=< h s

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

377

375

378 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

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

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

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

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

440 g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v

441 g' s (ArrayLiteral vs) = foldMap (g'' s) vs

442 g' s (ObjectLiteral vs) = foldMap (g'' s . snd) vs

443− g' s (ObjectConstructor vs) = foldMap (g'' s) (mapMaybe snd vs)

444 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1

443 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1

445 g' s (Accessor _ v1) = g'' s v1

444 g' s (Accessor _ v1) = g'' s v1

446 g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs

445 g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs

447− g' s (ObjectUpdater obj vs) = foldMap (g'' s) obj <> foldMap (g'' s) (mapMaybe snd vs)

448 g' s (Abs (Left name) v1) =

446 g' s (Abs (Left name) v1) =

449 let s' = S.insert name s

447 let s' = S.insert name s

450 in g'' s' v1

448 in g'' s' v1

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

465 h'' s a = h s a <> h' s a

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

466

464

467 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

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

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

470− h' s (NamedBinder name b1) =

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

471− let s' = S.insert name s

472− in h'' s' b1

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

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

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

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

475 h' _ _ = mempty

473 h' _ _ = mempty

src/Language/PureScript/Constants.hs+3

@@ -98,6 +98,9 @@ eq = "eq"

98notEq :: String

99notEq = "notEq"

100

101+compare :: String

102+compare = "compare"

103+

101(&&) :: String

104(&&) :: String

102(&&) = "&&"

105(&&) = "&&"

103

106

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.hs+1−1

@@ -11,4 +11,4 @@ import Language.PureScript.Docs.RenderedCode.Types as Docs

11import Language.PureScript.Docs.RenderedCode.Render as Docs

12import Language.PureScript.Docs.Convert as Docs

13import Language.PureScript.Docs.Render as Docs

14−import Language.PureScript.Docs.ParseAndDesugar as Docs

14+import Language.PureScript.Docs.ParseAndBookmark as Docs

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

@@ -31,31 +31,29 @@ import qualified Language.PureScript.Docs.Render as Render

31renderModulesAsMarkdown ::

32 (Functor m, Applicative m,

33 MonadError P.MultipleErrors m) =>

34− P.Env ->

35 [P.Module] ->

34 [P.Module] ->

36 m String

35 m String

37−renderModulesAsMarkdown env =

36+renderModulesAsMarkdown =

38− fmap (runDocs . modulesAsMarkdown) . Convert.convertModules env

37+ fmap (runDocs . modulesAsMarkdown) . Convert.convertModules

39

38

40modulesAsMarkdown :: [Module] -> Docs

39modulesAsMarkdown :: [Module] -> Docs

41modulesAsMarkdown = mapM_ moduleAsMarkdown

40modulesAsMarkdown = mapM_ moduleAsMarkdown

42

41

43moduleAsMarkdown :: Module -> Docs

42moduleAsMarkdown :: Module -> Docs

44moduleAsMarkdown Module{..} = do

43moduleAsMarkdown Module{..} = do

45− headerLevel 2 $ "Module " ++ modName

44+ headerLevel 2 $ "Module " ++ P.runModuleName modName

46 spacer

45 spacer

47 for_ modComments tell'

46 for_ modComments tell'

48 mapM_ (declAsMarkdown modName) modDeclarations

47 mapM_ (declAsMarkdown modName) modDeclarations

49 spacer

48 spacer

50 for_ modReExports $ \(mn, decls) -> do

49 for_ modReExports $ \(mn, decls) -> do

51− let modName' = P.runModuleName mn

52− headerLevel 3 $ "Re-exported from " ++ modName' ++ ":"

50+ headerLevel 3 $ "Re-exported from " ++ P.runModuleName mn ++ ":"

53 spacer

51 spacer

54− mapM_ (declAsMarkdown modName') decls

52+ mapM_ (declAsMarkdown mn) decls

55

53

56−declAsMarkdown :: String -> Declaration -> Docs

54+declAsMarkdown :: P.ModuleName -> Declaration -> Docs

57declAsMarkdown mn decl@Declaration{..} = do

55declAsMarkdown mn decl@Declaration{..} = do

58− let options = defaultRenderTypeOptions { currentModule = Just (P.moduleNameFromString mn) }

56+ let options = defaultRenderTypeOptions { currentModule = Just mn }

59 headerLevel 4 (ticks declTitle)

57 headerLevel 4 (ticks declTitle)

60 spacer

58 spacer

61

59

src/Language/PureScript/Docs/Convert.hs+139−30

@@ -16,12 +16,17 @@ module Language.PureScript.Docs.Convert

16import Prelude ()

17import Prelude.Compat

18

19−import Control.Monad.Error.Class (MonadError)

19+import Control.Arrow ((&&&), second)

20−import Control.Arrow ((&&&))

21import Control.Category ((>>>))

20import Control.Category ((>>>))

21+import Control.Monad

22+import Control.Monad.State (runStateT)

23+import Control.Monad.Writer.Strict (runWriterT)

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

22import qualified Data.Map as Map

25import qualified Data.Map as Map

23

26

27+import Text.Parsec (eof)

24import qualified Language.PureScript as P

28import qualified Language.PureScript as P

29+import qualified Language.PureScript.Constants as C

25

30

26import Language.PureScript.Docs.Types

31import Language.PureScript.Docs.Types

27import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks)

32import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks)

@@ -33,18 +38,17 @@ import Language.PureScript.Docs.Convert.ReExports (updateReExports)

33-- documentation.

38-- documentation.

34--

39--

35convertModulesInPackage ::

40convertModulesInPackage ::

36− (Functor m, MonadError P.MultipleErrors m) =>

41+ (Functor m, Applicative m, MonadError P.MultipleErrors m) =>

37− P.Env ->

38 [InPackage P.Module] ->

42 [InPackage P.Module] ->

39 m [Module]

43 m [Module]

40−convertModulesInPackage env modules =

44+convertModulesInPackage modules =

41 go modules

45 go modules

42 where

46 where

43 localNames =

47 localNames =

44− map (P.runModuleName . P.getModuleName) (takeLocals modules)

48+ map P.getModuleName (takeLocals modules)

45 go =

49 go =

46 map ignorePackage

50 map ignorePackage

47− >>> convertModules env

51+ >>> convertModules

48 >>> fmap (filter ((`elem` localNames) . modName))

52 >>> fmap (filter ((`elem` localNames) . modName))

49

53

50-- |

54-- |

@@ -53,35 +57,140 @@ convertModulesInPackage env modules =

53-- imports/exports information about the list of modules, which is needed for

57-- imports/exports information about the list of modules, which is needed for

54-- documenting re-exports.

58-- documenting re-exports.

55--

59--

56−-- Preconditions:

60+-- Note that the whole module dependency graph must be included in the list; if

61+-- some modules import things from other modules, then those modules must also

62+-- be included.

57--

63--

58−-- * If any module in the list re-exports documentation from other

64+-- For value declarations, if explicit type signatures are omitted, or a

59−-- modules, those modules must also be included in the list.

65+-- wildcard type is used, then we typecheck the modules and use the inferred

60−-- * The modules passed must have had names desugared and re-exports

66+-- types.

61−-- elaborated first.

62−--

63−-- If either of these are not satisfied, an internal error will be thrown. To

64−-- avoid this, it is recommended to use

65−-- Language.PureScript.Docs.ParseAndDesugar to construct the inputs to this

66−-- function.

67--

68convertModules ::

69− (Functor m, MonadError P.MultipleErrors m) =>

69+ (Functor m, Applicative m, MonadError P.MultipleErrors m) =>

70− P.Env ->

71 [P.Module] ->

70 [P.Module] ->

72 m [Module]

71 m [Module]

73−convertModules env =

72+convertModules =

73+ P.sortModules

74+ >>> fmap (fst >>> map importPrim)

74− P.sortModules >>> fmap (convertSorted env . fst)

75+ >=> convertSorted

76+

77+importPrim :: P.Module -> P.Module

78+importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])

75

79

76-- |

80-- |

77-- Convert a sorted list of modules.

81-- Convert a sorted list of modules.

78--

82--

79−convertSorted :: P.Env -> [P.Module] -> [Module]

83+convertSorted ::

84+ (Functor m, Applicative m, MonadError P.MultipleErrors m) =>

85+ [P.Module] ->

86+ m [Module]

80−convertSorted env modules =

87+convertSorted modules = do

81− let

88+ (env, convertedModules) <- second (map convertSingleModule) <$> partiallyDesugar modules

82− traversalOrder =

89+

83− map P.getModuleName modules

90+ modulesWithTypes <- typeCheckIfNecessary modules convertedModules

84− moduleMap =

91+ let moduleMap = Map.fromList (map (modName &&& id) modulesWithTypes)

85− Map.fromList $ map (P.getModuleName &&& convertSingleModule) modules

92+

86− in

93+ let traversalOrder = map P.getModuleName modules

87− Map.elems (updateReExports env traversalOrder moduleMap)

94+ pure (Map.elems (updateReExports env traversalOrder moduleMap))

95+

96+-- |

97+-- If any exported value declarations have either wildcard type signatures, or

98+-- none at all, then typecheck in order to fill them in with the inferred

99+-- types.

100+--

101+typeCheckIfNecessary ::

102+ (Functor m, Applicative m, MonadError P.MultipleErrors m) =>

103+ [P.Module] ->

104+ [Module] ->

105+ m [Module]

106+typeCheckIfNecessary modules convertedModules =

107+ if any hasWildcards convertedModules

108+ then go

109+ else pure convertedModules

110+

111+ where

112+ hasWildcards =

113+ any ((==) (ValueDeclaration P.TypeWildcard) . declInfo) . modDeclarations

114+

115+ go = do

116+ checkEnv <- snd <$> typeCheck modules

117+ pure (map (insertValueTypes checkEnv) convertedModules)

118+

119+-- |

120+-- Typechecks all the modules together. Also returns the final 'P.Environment',

121+-- which is useful for adding in inferred types where explicit declarations

122+-- were not provided.

123+--

124+typeCheck ::

125+ (Functor m, MonadError P.MultipleErrors m) =>

126+ [P.Module] ->

127+ m ([P.Module], P.Environment)

128+typeCheck =

129+ (P.desugar [] >=> check)

130+ >>> fmap (second P.checkEnv)

131+ >>> P.evalSupplyT 0

132+ >>> ignoreWarnings

133+

134+ where

135+ check ms =

136+ runStateT

137+ (traverse P.typeCheckModule ms)

138+ (P.emptyCheckState P.initEnvironment)

139+

140+ ignoreWarnings =

141+ fmap fst . runWriterT

142+

143+-- |

144+-- Updates all the types of the ValueDeclarations inside the module based on

145+-- their types inside the given Environment.

146+--

147+insertValueTypes ::

148+ P.Environment -> Module -> Module

149+insertValueTypes env m =

150+ m { modDeclarations = map go (modDeclarations m) }

151+ where

152+ go (d@Declaration { declInfo = ValueDeclaration P.TypeWildcard }) =

153+ let

154+ ident = parseIdent (declTitle d)

155+ ty = lookupName ident

156+ in

157+ d { declInfo = ValueDeclaration ty }

158+ go other =

159+ other

160+

161+ parseIdent =

162+ either (err . ("failed to parse Ident: " ++)) id . runParser P.parseIdent

163+

164+ lookupName name =

165+ let key = (modName m, name)

166+ in case Map.lookup key (P.names env) of

167+ Just (ty, _, _) ->

168+ ty

169+ Nothing ->

170+ err ("name not found: " ++ show key)

171+

172+ err msg =

173+ P.internalError ("Docs.Convert.insertValueTypes: " ++ msg)

174+

175+runParser :: P.TokenParser a -> String -> Either String a

176+runParser p s = either (Left . show) Right $ do

177+ ts <- P.lex "" s

178+ P.runTokenParser "" (p <* eof) ts

179+

180+-- |

181+-- Partially desugar modules so that they are suitable for extracting

182+-- documentation information from.

183+--

184+partiallyDesugar ::

185+ (Functor m, Applicative m, MonadError P.MultipleErrors m) =>

186+ [P.Module]

187+ -> m (P.Env, [P.Module])

188+partiallyDesugar = P.evalSupplyT 0 . desugar'

189+ where

190+ desugar' =

191+ traverse P.desugarDoModule

192+ >=> P.desugarCasesModule

193+ >=> P.desugarTypeDeclarationsModule

194+ >=> ignoreWarnings . P.desugarImportsWithEnv []

195+

196+ ignoreWarnings = fmap fst . runWriterT

src/Language/PureScript/Docs/Convert/Single.hs+7−3

@@ -29,7 +29,7 @@ import Language.PureScript.Docs.Types

29--

30convertSingleModule :: P.Module -> Module

31convertSingleModule m@(P.Module _ coms moduleName _ _) =

32− Module (P.runModuleName moduleName) comments (declarations m) []

32+ Module moduleName comments (declarations m) []

33 where

34 comments = convertComments coms

35 declarations =

@@ -109,7 +109,7 @@ addDefaultFixity decl@Declaration{..}

109 defaultFixity = P.Fixity P.Infixl (-1)

110

111getDeclarationTitle :: P.Declaration -> Maybe String

112−getDeclarationTitle (P.TypeDeclaration name _) = Just (P.showIdent name)

112+getDeclarationTitle (P.ValueDeclaration name _ _ _) = Just (P.showIdent name)

113getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name)

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

115getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name)

@@ -135,8 +135,12 @@ basicDeclaration :: String -> DeclarationInfo -> Maybe IntermediateDeclaration

135basicDeclaration title info = Just $ Right $ mkDeclaration title info

136

137convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration

138−convertDeclaration (P.TypeDeclaration _ ty) title =

138+convertDeclaration (P.ValueDeclaration _ _ _ (Right (P.TypedValue _ _ ty))) title =

139 basicDeclaration title (ValueDeclaration ty)

140+convertDeclaration (P.ValueDeclaration _ _ _ _) title =

141+ -- If no explicit type declaration was provided, insert a wildcard, so that

142+ -- the actual type will be added during type checking.

143+ basicDeclaration title (ValueDeclaration P.TypeWildcard)

140convertDeclaration (P.ExternDeclaration _ ty) title =

144convertDeclaration (P.ExternDeclaration _ ty) title =

141 basicDeclaration title (ValueDeclaration ty)

145 basicDeclaration title (ValueDeclaration ty)

142convertDeclaration (P.DataDeclaration dtype _ args ctors) title =

146convertDeclaration (P.DataDeclaration dtype _ args ctors) title =

src/Language/PureScript/Docs/ParseAndDesugar.hs → src/Language/PureScript/Docs/ParseAndBookmark.hsrenamed+16−53

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

1{-# LANGUAGE TupleSections #-}

2{-# LANGUAGE FlexibleContexts #-}

3

4−module Language.PureScript.Docs.ParseAndDesugar

4+module Language.PureScript.Docs.ParseAndBookmark

5− ( parseAndDesugar

5+ ( parseAndBookmark

6 ) where

7

8import Prelude ()

@@ -10,16 +10,13 @@ import Prelude.Compat

10

11import qualified Data.Map as M

12import Control.Arrow (first)

13−import Control.Monad

14

13

15−import Control.Monad.Writer.Strict (runWriterT)

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

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

17import Control.Monad.IO.Class (MonadIO(..))

15import Control.Monad.IO.Class (MonadIO(..))

18

16

19import Web.Bower.PackageMeta (PackageName)

17import Web.Bower.PackageMeta (PackageName)

20

18

21import qualified Language.PureScript as P

19import qualified Language.PureScript as P

22−import qualified Language.PureScript.Constants as C

23import Language.PureScript.Docs.Types

20import Language.PureScript.Docs.Types

24import Language.PureScript.Docs.Convert (collectBookmarks)

21import Language.PureScript.Docs.Convert (collectBookmarks)

25

22

@@ -35,23 +32,18 @@ import Language.PureScript.Docs.Convert (collectBookmarks)

35-- * Parse all of the input and dependency source files

32-- * Parse all of the input and dependency source files

36-- * Associate each dependency module with its package name, thereby

33-- * Associate each dependency module with its package name, thereby

37-- distinguishing these from local modules

34-- distinguishing these from local modules

38−-- * Partially desugar all of the resulting modules (just enough for

39−-- producing documentation from them)

40-- * Collect a list of bookmarks from the whole set of source files

35-- * Collect a list of bookmarks from the whole set of source files

41−-- * Return the desugared modules, the bookmarks, and the imports/exports

36+-- * Return the parsed modules and the bookmarks

42−-- Env (which is needed for producing documentation).

37+parseAndBookmark ::

43−parseAndDesugar ::

44 (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadIO m) =>

38 (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadIO m) =>

45 [FilePath]

39 [FilePath]

46 -> [(PackageName, FilePath)]

40 -> [(PackageName, FilePath)]

47− -> m ([InPackage P.Module], [Bookmark], P.Env)

41+ -> m ([InPackage P.Module], [Bookmark])

48−parseAndDesugar inputFiles depsFiles = do

42+parseAndBookmark inputFiles depsFiles = do

49 inputFiles' <- traverse (parseAs Local) inputFiles

43 inputFiles' <- traverse (parseAs Local) inputFiles

50 depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles

44 depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles

51

45

52− ms <- parseFiles (inputFiles' ++ depsFiles')

46+ addBookmarks <$> parseFiles (inputFiles' ++ depsFiles')

53− ms' <- sortModules (map snd ms)

54− desugarWithBookmarks ms ms'

55

47

56parseFiles ::

48parseFiles ::

57 (MonadError P.MultipleErrors m, MonadIO m) =>

49 (MonadError P.MultipleErrors m, MonadIO m) =>

@@ -60,29 +52,16 @@ parseFiles ::

60parseFiles =

52parseFiles =

61 throwLeft . P.parseModulesFromFiles fileInfoToString

53 throwLeft . P.parseModulesFromFiles fileInfoToString

62

54

63−sortModules ::

55+addBookmarks ::

64− (Functor m, MonadError P.MultipleErrors m, MonadIO m) =>

65− [P.Module]

66− -> m [P.Module]

67−sortModules =

68− fmap fst . throwLeft . sortModules' . map importPrim

69− where

70− sortModules' :: [P.Module] -> Either P.MultipleErrors ([P.Module], P.ModuleGraph)

71− sortModules' = P.sortModules

72−

73−desugarWithBookmarks ::

74− (MonadError P.MultipleErrors m, MonadIO m) =>

75 [(FileInfo, P.Module)]

56 [(FileInfo, P.Module)]

76− -> [P.Module]

77− -> m ([InPackage P.Module], [Bookmark], P.Env)

57+ -> ([InPackage P.Module], [Bookmark])

78−desugarWithBookmarks msInfo msSorted = do

58+addBookmarks msInfo =

79− (env, msDesugared) <- throwLeft (desugar msSorted)

59+ let

80−

81− let msDeps = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) msInfo)

60+ msDeps = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) msInfo)

82− msPackages = map (addPackage msDeps) msDesugared

61+ msPackages = map (addPackage msDeps . snd) msInfo

83− bookmarks = concatMap collectBookmarks msPackages

62+ bookmarks = concatMap collectBookmarks msPackages

84−

63+ in

85− return (msPackages, bookmarks, env)

64+ (msPackages, bookmarks)

86

65

87throwLeft :: (MonadError l m) => Either l r -> m r

66throwLeft :: (MonadError l m) => Either l r -> m r

88throwLeft = either throwError return

67throwLeft = either throwError return

@@ -100,22 +79,6 @@ fileInfoToString :: FileInfo -> FilePath

100fileInfoToString (Local fn) = fn

79fileInfoToString (Local fn) = fn

101fileInfoToString (FromDep _ fn) = fn

80fileInfoToString (FromDep _ fn) = fn

102

81

103−importPrim :: P.Module -> P.Module

104−importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])

105−

106−desugar ::

107− (Functor m, Applicative m, MonadError P.MultipleErrors m) =>

108− [P.Module]

109− -> m (P.Env, [P.Module])

110−desugar = P.evalSupplyT 0 . desugar'

111− where

112− desugar' =

113− traverse P.desugarDoModule

114− >=> P.desugarCasesModule

115− >=> ignoreWarnings . P.desugarImportsWithEnv []

116−

117− ignoreWarnings m = liftM fst (runWriterT m)

118−

119parseFile :: FilePath -> IO (FilePath, String)

82parseFile :: FilePath -> IO (FilePath, String)

120parseFile input' = (,) input' <$> readFile input'

83parseFile input' = (,) input' <$> readFile input'

121

84

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+8−5

@@ -73,7 +73,7 @@ packageName :: Package a -> PackageName

73packageName = bowerName . pkgMeta

74

75data Module = Module

76− { modName :: String

76+ { modName :: P.ModuleName

77 , modComments :: Maybe String

78 , modDeclarations :: [Declaration]

79 -- Re-exported values from other modules

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

@@ -346,7 +346,7 @@ parseVersion' str =

346

347asModule :: Parse PackageError Module

348asModule =

349− Module <$> key "name" asString

349+ Module <$> key "name" (P.moduleNameFromString <$> asString)

350 <*> key "comments" (perhaps asString)

351 <*> key "declarations" (eachInArray asDeclaration)

352 <*> key "reExports" (eachInArray asReExport)

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

@@ -512,7 +515,7 @@ instance A.ToJSON NotYetKnown where

512

515

513instance A.ToJSON Module where

516instance A.ToJSON Module where

514 toJSON Module{..} =

517 toJSON Module{..} =

515− A.object [ "name" .= modName

518+ A.object [ "name" .= P.runModuleName modName

516 , "comments" .= modComments

519 , "comments" .= modComments

517 , "declarations" .= modDeclarations

520 , "declarations" .= modDeclarations

518 , "reExports" .= map toObj modReExports

521 , "reExports" .= map toObj modReExports

src/Language/PureScript/Errors.hs+66−20

@@ -24,6 +24,7 @@ import Control.Arrow ((&&&))

24import Language.PureScript.Crash

25import Language.PureScript.AST

26import Language.PureScript.Pretty

27+import Language.PureScript.Pretty.Common (before)

27import Language.PureScript.Types

28import Language.PureScript.Types

28import Language.PureScript.Names

29import Language.PureScript.Names

29import Language.PureScript.Kinds

30import Language.PureScript.Kinds

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

112 | InvalidNewtype (ProperName 'TypeName)

113 | InvalidNewtype (ProperName 'TypeName)

113 | InvalidInstanceHead Type

114 | InvalidInstanceHead Type

114 | TransitiveExportError DeclarationRef [DeclarationRef]

115 | TransitiveExportError DeclarationRef [DeclarationRef]

116+ | TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName)

115 | ShadowedName Ident

117 | ShadowedName Ident

116 | ShadowedTypeVar String

118 | ShadowedTypeVar String

117 | UnusedTypeVar String

119 | UnusedTypeVar String

@@ -128,6 +130,7 @@ data SimpleErrorMessage

128 | UnusedDctorImport (ProperName 'TypeName)

130 | UnusedDctorImport (ProperName 'TypeName)

129 | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName]

131 | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName]

130 | DeprecatedOperatorDecl String

132 | DeprecatedOperatorDecl String

133+ | DeprecatedOperatorSection Expr (Either Expr Expr)

131 | DeprecatedQualifiedSyntax ModuleName ModuleName

134 | DeprecatedQualifiedSyntax ModuleName ModuleName

132 | DeprecatedClassImport ModuleName (ProperName 'ClassName)

135 | DeprecatedClassImport ModuleName (ProperName 'ClassName)

133 | DeprecatedClassExport (ProperName 'ClassName)

136 | DeprecatedClassExport (ProperName 'ClassName)

@@ -142,6 +145,8 @@ data SimpleErrorMessage

142 | ImplicitImport ModuleName [DeclarationRef]

145 | ImplicitImport ModuleName [DeclarationRef]

143 | HidingImport ModuleName [DeclarationRef]

146 | HidingImport ModuleName [DeclarationRef]

144 | CaseBinderLengthDiffers Int [Binder]

147 | CaseBinderLengthDiffers Int [Binder]

148+ | IncorrectAnonymousArgument

149+ | InvalidOperatorInBinder Ident Ident

145 deriving (Show)

150 deriving (Show)

146

151

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

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

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

287 InvalidNewtype{} -> "InvalidNewtype"

292 InvalidNewtype{} -> "InvalidNewtype"

288 InvalidInstanceHead{} -> "InvalidInstanceHead"

293 InvalidInstanceHead{} -> "InvalidInstanceHead"

289 TransitiveExportError{} -> "TransitiveExportError"

294 TransitiveExportError{} -> "TransitiveExportError"

295+ TransitiveDctorExportError{} -> "TransitiveDctorExportError"

290 ShadowedName{} -> "ShadowedName"

296 ShadowedName{} -> "ShadowedName"

291 ShadowedTypeVar{} -> "ShadowedTypeVar"

297 ShadowedTypeVar{} -> "ShadowedTypeVar"

292 UnusedTypeVar{} -> "UnusedTypeVar"

298 UnusedTypeVar{} -> "UnusedTypeVar"

@@ -303,6 +309,7 @@ errorCode em = case unwrapErrorMessage em of

303 UnusedDctorImport{} -> "UnusedDctorImport"

309 UnusedDctorImport{} -> "UnusedDctorImport"

304 UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"

310 UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"

305 DeprecatedOperatorDecl{} -> "DeprecatedOperatorDecl"

311 DeprecatedOperatorDecl{} -> "DeprecatedOperatorDecl"

312+ DeprecatedOperatorSection{} -> "DeprecatedOperatorSection"

306 DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax"

313 DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax"

307 DeprecatedClassImport{} -> "DeprecatedClassImport"

314 DeprecatedClassImport{} -> "DeprecatedClassImport"

308 DeprecatedClassExport{} -> "DeprecatedClassExport"

315 DeprecatedClassExport{} -> "DeprecatedClassExport"

@@ -317,6 +324,8 @@ errorCode em = case unwrapErrorMessage em of

317 ImplicitImport{} -> "ImplicitImport"

324 ImplicitImport{} -> "ImplicitImport"

318 HidingImport{} -> "HidingImport"

325 HidingImport{} -> "HidingImport"

319 CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"

326 CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"

327+ IncorrectAnonymousArgument -> "IncorrectAnonymousArgument"

328+ InvalidOperatorInBinder{} -> "InvalidOperatorInBinder"

320

329

321-- |

330-- |

322-- A stack trace for an error

331-- A stack trace for an error

@@ -424,7 +433,7 @@ wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ error

424-- TODO Other possible suggestions:

433-- TODO Other possible suggestions:

425-- WildcardInferredType - source span not small enough

434-- WildcardInferredType - source span not small enough

426-- DuplicateSelectiveImport - would require 2 ranges to remove and 1 insert

435-- DuplicateSelectiveImport - would require 2 ranges to remove and 1 insert

427−-- DeprecatedClassExport, DeprecatedClassImport, would want to replace smaller span?

436+-- DeprecatedClassExport, DeprecatedClassImport, DeprecatedOperatorSection, would want to replace smaller span?

428errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion

437errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion

429errorSuggestion err = case err of

438errorSuggestion err = case err of

430 UnusedImport{} -> emptySuggestion

439 UnusedImport{} -> emptySuggestion

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

784 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: "

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

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

786 ]

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+ ]

787 renderSimpleErrorMessage (ShadowedName nm) =

800 renderSimpleErrorMessage (ShadowedName nm) =

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

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

789 renderSimpleErrorMessage (ShadowedTypeVar tv) =

802 renderSimpleErrorMessage (ShadowedTypeVar tv) =

@@ -798,7 +811,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

798 renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =

811 renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =

799 line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors."

812 line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors."

800 renderSimpleErrorMessage (ImportHidingModule name) =

813 renderSimpleErrorMessage (ImportHidingModule name) =

801− paras [ line $ "'hiding' imports cannot be used to hide modules."

814+ paras [ line "'hiding' imports cannot be used to hide modules."

802 , line $ "An attempt was made to hide the import of " ++ runModuleName name

815 , line $ "An attempt was made to hide the import of " ++ runModuleName name

803 ]

816 ]

804 renderSimpleErrorMessage (WildcardInferredType ty) =

817 renderSimpleErrorMessage (WildcardInferredType ty) =

@@ -812,14 +825,14 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

812 , indent $ typeAsBox ty

825 , indent $ typeAsBox ty

813 ]

826 ]

814 renderSimpleErrorMessage (NotExhaustivePattern bs b) =

827 renderSimpleErrorMessage (NotExhaustivePattern bs b) =

815− paras $ [ line "A case expression could not be determined to cover all inputs."

828+ paras [ line "A case expression could not be determined to cover all inputs."

816− , line "The following additional cases are required to cover all inputs:\n"

829+ , line "The following additional cases are required to cover all inputs:\n"

817− , indent $ paras $

830+ , indent $ paras $

818− [ Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ]

831+ [ Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ]

819− ++ [ line "..." | not b ]

832+ ++ [ line "..." | not b ]

820− , line "Or alternatively, add a Partial constraint to the type of the enclosing value."

833+ , line "Or alternatively, add a Partial constraint to the type of the enclosing value."

821− , line "Non-exhaustive patterns for values without a `Partial` constraint will be disallowed in PureScript 0.9."

834+ , line "Non-exhaustive patterns for values without a `Partial` constraint will be disallowed in PureScript 0.9."

822− ]

835+ ]

823 renderSimpleErrorMessage (OverlappingPattern bs b) =

836 renderSimpleErrorMessage (OverlappingPattern bs b) =

824 paras $ [ line "A case expression contains unreachable cases:\n"

837 paras $ [ line "A case expression contains unreachable cases:\n"

825 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))

838 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))

@@ -835,7 +848,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

835 renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) =

848 renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) =

836 paras [ line $ "The import of module " ++ runModuleName mn ++ " contains the following unused references:"

849 paras [ line $ "The import of module " ++ runModuleName mn ++ " contains the following unused references:"

837 , indent $ paras $ map line names

850 , indent $ paras $ map line names

838− , line $ "It could be replaced with:"

851+ , line "It could be replaced with:"

839 , indent $ line $ showSuggestion msg ]

852 , indent $ line $ showSuggestion msg ]

840

853

841 renderSimpleErrorMessage (UnusedDctorImport name) =

854 renderSimpleErrorMessage (UnusedDctorImport name) =

@@ -849,15 +862,39 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

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

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

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

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

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

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

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

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

853 ]

866 ]

854

867

868+ renderSimpleErrorMessage (DeprecatedOperatorSection op val) =

869+ paras [ line "An operator section uses legacy syntax. Operator sections are now written using anonymous function syntax:"

870+ , indent $ foldr1 before $

871+ case val of

872+ Left l ->

873+ [ line "("

874+ , prettyPrintValue valueDepth l

875+ , line " "

876+ , renderOperator op

877+ , line " _)"

878+ ]

879+ Right r ->

880+ [ line "(_ "

881+ , renderOperator op

882+ , line " "

883+ , prettyPrintValue valueDepth r

884+ , line ")"

885+ ]

886+ , line "Support for legacy operator sections will be removed in PureScript 0.9."

887+ ]

888+ where

889+ renderOperator (PositionedValue _ _ ex) = renderOperator ex

890+ renderOperator (Var (Qualified _ (Op ident))) = line ident

891+ renderOperator other = Box.hcat Box.top [ line "`", prettyPrintValue valueDepth other, line "`" ]

855 renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) =

892 renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) =

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

893+ paras [ line "Import uses the deprecated 'qualified' syntax:"

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

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

858 , line "Should instead use the form:"

895 , line "Should instead use the form:"

859 , indent $ line $ "import " ++ runModuleName name ++ " as " ++ runModuleName qualName

896 , indent $ line $ "import " ++ runModuleName name ++ " as " ++ runModuleName qualName

860− , line $ "The deprecated syntax will be removed in PureScript 0.9."

897+ , line "The deprecated syntax will be removed in PureScript 0.9."

861 ]

898 ]

862

899

863 renderSimpleErrorMessage (DeprecatedClassImport mn name) =

900 renderSimpleErrorMessage (DeprecatedClassImport mn name) =

@@ -865,15 +902,15 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

865 , indent $ line $ runProperName name

902 , indent $ line $ runProperName name

866 , line "Should instead use the form:"

903 , line "Should instead use the form:"

867 , indent $ line $ "class " ++ runProperName name

904 , indent $ line $ "class " ++ runProperName name

868− , line $ "The deprecated syntax will be removed in PureScript 0.9."

905+ , line "The deprecated syntax will be removed in PureScript 0.9."

869 ]

906 ]

870

907

871 renderSimpleErrorMessage (DeprecatedClassExport name) =

908 renderSimpleErrorMessage (DeprecatedClassExport name) =

872− paras [ line $ "Class export uses deprecated syntax that omits the 'class' keyword:"

909+ paras [ line "Class export uses deprecated syntax that omits the 'class' keyword:"

873 , indent $ line $ runProperName name

910 , indent $ line $ runProperName name

874 , line "Should instead use the form:"

911 , line "Should instead use the form:"

875 , indent $ line $ "class " ++ runProperName name

912 , indent $ line $ "class " ++ runProperName name

876− , line $ "The deprecated syntax will be removed in PureScript 0.9."

913+ , line "The deprecated syntax will be removed in PureScript 0.9."

877 ]

914 ]

878

915

879 renderSimpleErrorMessage (RedundantUnqualifiedImport name imp) =

916 renderSimpleErrorMessage (RedundantUnqualifiedImport name imp) =

@@ -915,9 +952,18 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

915 ]

952 ]

916

953

917 renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) =

954 renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) =

918− paras $ [ line $ "Binder list length differs in case alternative:"

955+ paras [ line "Binder list length differs in case alternative:"

919− , indent $ line $ intercalate ", " $ fmap prettyPrintBinderAtom bs

956+ , indent $ line $ intercalate ", " $ fmap prettyPrintBinderAtom bs

920− , line $ "Expecting " ++ show l ++ " binder" ++ (if l == 1 then "" else "s") ++ "." ]

957+ , line $ "Expecting " ++ show l ++ " binder" ++ (if l == 1 then "" else "s") ++ "."

958+ ]

959+

960+ renderSimpleErrorMessage IncorrectAnonymousArgument =

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

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+ ]

921

967

922 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

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

923 renderHint (ErrorUnifyingTypes t1 t2) detail =

969 renderHint (ErrorUnifyingTypes t1 t2) 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)

78

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/Linter.hs+1

@@ -71,6 +71,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl

71 go d | Just i <- getDeclIdent d

72 , i `S.member` s = errorMessage (ShadowedName i)

73 | otherwise = mempty

74+ stepE _ (OperatorSection op val) = errorMessage $ DeprecatedOperatorSection op val

74 stepE _ _ = mempty

75 stepE _ _ = mempty

75

76

76 stepB :: S.Set Ident -> Binder -> MultipleErrors

77 stepB :: S.Set Ident -> Binder -> MultipleErrors

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 _ = []

67

68

src/Language/PureScript/Parser/Declarations.hs+34−23

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

@@ -312,18 +315,17 @@ parseArrayLiteral :: TokenParser Expr

312parseArrayLiteral = ArrayLiteral <$> squares (commaSep parseValue)

315parseArrayLiteral = ArrayLiteral <$> squares (commaSep parseValue)

313

316

314parseObjectLiteral :: TokenParser Expr

317parseObjectLiteral :: TokenParser Expr

315−parseObjectLiteral = ObjectConstructor <$> braces (commaSep parseIdentifierAndValue)

318+parseObjectLiteral = ObjectLiteral <$> braces (commaSep parseIdentifierAndValue)

316

319

317−parseIdentifierAndValue :: TokenParser (String, Maybe Expr)

320+parseIdentifierAndValue :: TokenParser (String, Expr)

318parseIdentifierAndValue =

321parseIdentifierAndValue =

319 do

322 do

320 name <- C.indented *> lname

323 name <- C.indented *> lname

321− b <- P.option (Just $ Var $ Qualified Nothing (Ident name)) rest

324+ b <- P.option (Var $ Qualified Nothing (Ident name)) rest

322 return (name, b)

325 return (name, b)

323 <|> (,) <$> (C.indented *> stringLiteral) <*> rest

326 <|> (,) <$> (C.indented *> stringLiteral) <*> rest

324 where

327 where

325− rest = C.indented *> colon *> C.indented *> val

328+ rest = C.indented *> colon *> C.indented *> parseValue

326− val = P.try (Just <$> parseValue) <|> (underscore *> pure Nothing)

327

329

328parseAbs :: TokenParser Expr

330parseAbs :: TokenParser Expr

329parseAbs = do

331parseAbs = do

@@ -373,13 +375,13 @@ parseLet = do

373

375

374parseValueAtom :: TokenParser Expr

376parseValueAtom :: TokenParser Expr

375parseValueAtom = P.choice

377parseValueAtom = P.choice

378+ [ parseAnonymousArgument

376− [ parseNumericLiteral

379+ , parseNumericLiteral

377 , parseCharLiteral

380 , parseCharLiteral

378 , parseStringLiteral

381 , parseStringLiteral

379 , parseBooleanLiteral

382 , parseBooleanLiteral

380 , parseArrayLiteral

383 , parseArrayLiteral

381 , P.try parseObjectLiteral

384 , P.try parseObjectLiteral

382− , P.try parseObjectGetter

383 , parseAbs

385 , parseAbs

384 , P.try parseConstructor

386 , P.try parseConstructor

385 , P.try parseVar

387 , P.try parseVar

@@ -389,8 +391,6 @@ parseValueAtom = P.choice

389 , parseLet

391 , parseLet

390 , P.try $ Parens <$> parens parseValue

392 , P.try $ Parens <$> parens parseValue

391 , parseOperatorSection

393 , parseOperatorSection

392− -- TODO: combine this with parseObjectGetter

393− , parseObjectUpdaterWildcard

394 ]

395

396-- |

@@ -406,11 +406,11 @@ parseOperatorSection = parens $ left <|> right

406 right = OperatorSection <$> parseInfixExpr <* indented <*> (Right <$> indexersAndAccessors)

407 left = flip OperatorSection <$> (Left <$> indexersAndAccessors) <* indented <*> parseInfixExpr

408

409−parsePropertyUpdate :: TokenParser (String, Maybe Expr)

409+parsePropertyUpdate :: TokenParser (String, Expr)

410parsePropertyUpdate = do

411 name <- lname <|> stringLiteral

412 _ <- C.indented *> equals

413− value <- C.indented *> (underscore *> pure Nothing) <|> (Just <$> parseValue)

413+ value <- C.indented *> parseValue

414 return (name, value)

415

416parseAccessor :: Expr -> TokenParser Expr

@@ -436,15 +436,12 @@ parseDoNotationElement = P.choice

436 , DoNotationValue <$> parseValue

437 ]

438

439−parseObjectGetter :: TokenParser Expr

440−parseObjectGetter = ObjectGetter <$> (underscore *> C.indented *> dot *> C.indented *> (lname <|> stringLiteral))

441−

442-- | Expressions including indexers and record updates

439-- | Expressions including indexers and record updates

443indexersAndAccessors :: TokenParser Expr

440indexersAndAccessors :: TokenParser Expr

444indexersAndAccessors = C.buildPostfixParser postfixTable parseValueAtom

441indexersAndAccessors = C.buildPostfixParser postfixTable parseValueAtom

445 where

442 where

446 postfixTable = [ parseAccessor

443 postfixTable = [ parseAccessor

447− , P.try . parseUpdaterBody . Just

444+ , P.try . parseUpdaterBody

448 ]

445 ]

449

446

450-- |

447-- |

@@ -466,11 +463,11 @@ parseValue = withSourceSpan PositionedValue

466 ]

463 ]

467 ]

464 ]

468

465

469−parseUpdaterBody :: Maybe Expr -> TokenParser Expr

466+parseUpdaterBody :: Expr -> TokenParser Expr

470−parseUpdaterBody v = ObjectUpdater v <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate)))

467+parseUpdaterBody v = ObjectUpdate v <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate)))

471

468

472−parseObjectUpdaterWildcard :: TokenParser Expr

469+parseAnonymousArgument :: TokenParser Expr

473−parseObjectUpdaterWildcard = underscore *> C.indented *> parseUpdaterBody Nothing

470+parseAnonymousArgument = underscore *> pure AnonymousArgument

474

471

475parseStringBinder :: TokenParser Binder

472parseStringBinder :: TokenParser Binder

476parseStringBinder = StringBinder <$> stringLiteral

473parseStringBinder = StringBinder <$> stringLiteral

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

525-- Parse a binder

522-- Parse a binder

526--

523--

527parseBinder :: TokenParser Binder

524parseBinder :: TokenParser Binder

525+parseBinder =

526+ withSourceSpan

527+ PositionedBinder

528+ ( P.buildExpressionParser operators

528−parseBinder = withSourceSpan PositionedBinder (buildPostfixParser postfixTable parseBinderAtom)

529+ . buildPostfixParser postfixTable

530+ $ parseBinderAtom

531+ )

529 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+ ]

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

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

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

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

532 ]

540 ]

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

541 , parseConstructorBinder

549 , parseConstructorBinder

542 , parseObjectBinder

550 , parseObjectBinder

543 , parseArrayBinder

551 , parseArrayBinder

544− , parens parseBinder

552+ , ParensInBinder <$> parens parseBinder

545 ] P.<?> "binder"

553 ] P.<?> "binder"

546

554

555+ parseOpBinder :: TokenParser Binder

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

557+

547-- |

558-- |

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

549--

560--

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

558 , parseNullaryConstructorBinder

569 , parseNullaryConstructorBinder

559 , parseObjectBinder

570 , parseObjectBinder

560 , parseArrayBinder

571 , parseArrayBinder

561− , parens parseBinder

572+ , ParensInBinder <$> parens parseBinder

562 ] P.<?> "binder"

573 ] P.<?> "binder"

563

574

564-- |

575-- |

src/Language/PureScript/Pretty/Values.hs+1−3

@@ -57,7 +57,6 @@ prettyPrintValue d (IfThenElse cond th el) =

57 ])

58prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val <> text ("." ++ show prop)

59prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> prettyPrintValue (d - 1) val) ps

60−prettyPrintValue d (ObjectUpdater o ps) = maybe (text "_") (prettyPrintValueAtom (d - 1)) o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> maybe (text "_") (prettyPrintValue (d - 1)) val) ps

61prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg

60prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg

62prettyPrintValue d (Abs (Left arg) val) = text ('\\' : showIdent arg ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)

61prettyPrintValue d (Abs (Left arg) val) = text ('\\' : showIdent arg ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)

63prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) =

62prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) =

@@ -86,8 +85,7 @@ prettyPrintValueAtom _ (BooleanLiteral True) = text "true"

86prettyPrintValueAtom _ (BooleanLiteral False) = text "false"

85prettyPrintValueAtom _ (BooleanLiteral False) = text "false"

87prettyPrintValueAtom d (ArrayLiteral xs) = list '[' ']' (prettyPrintValue (d - 1)) xs

86prettyPrintValueAtom d (ArrayLiteral xs) = list '[' ']' (prettyPrintValue (d - 1)) xs

88prettyPrintValueAtom d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ second Just `map` ps

87prettyPrintValueAtom d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ second Just `map` ps

89−prettyPrintValueAtom d (ObjectConstructor ps) = prettyPrintObject (d - 1) ps

88+prettyPrintValueAtom _ AnonymousArgument = text "_"

90−prettyPrintValueAtom _ (ObjectGetter prop) = text $ "_." ++ show prop

91prettyPrintValueAtom _ (Constructor name) = text $ runProperName (disqualify name)

89prettyPrintValueAtom _ (Constructor name) = text $ runProperName (disqualify name)

92prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident)

90prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident)

93prettyPrintValueAtom d (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue (d - 1) op) `beforeWithSpace` prettyPrintValue (d - 1) val) `before` text ")"

91prettyPrintValueAtom d (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue (d - 1) op) `beforeWithSpace` prettyPrintValue (d - 1) val) `before` text ")"

src/Language/PureScript/Publish.hs+4−4

@@ -146,15 +146,15 @@ preparePackage' opts = do

146getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module])

147getModulesAndBookmarks = do

148 (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles

149− (modules', bookmarks, env) <- parseAndDesugar inputFiles depsFiles

149+ (modules', bookmarks) <- parseAndBookmark inputFiles depsFiles

150

151− case runExcept (D.convertModulesInPackage env modules') of

151+ case runExcept (D.convertModulesInPackage modules') of

152 Right modules -> return (bookmarks, modules)

153 Left err -> userError (CompileError err)

154

155 where

156− parseAndDesugar inputFiles depsFiles = do

156+ parseAndBookmark inputFiles depsFiles = do

157− r <- liftIO . runExceptT $ D.parseAndDesugar inputFiles depsFiles

157+ r <- liftIO . runExceptT $ D.parseAndBookmark inputFiles depsFiles

158 case r of

159 Right r' ->

160 return r'

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

@@ -17,6 +17,7 @@ import Prelude.Compat

17import Data.List (find, nub)

18import Data.Maybe (fromMaybe, mapMaybe)

19

20+import Control.Arrow (first)

20import Control.Monad

21import Control.Monad

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

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

22import Control.Monad.Writer (MonadWriter(..), censor)

23import Control.Monad.Writer (MonadWriter(..), censor)

@@ -54,7 +55,7 @@ desugarImportsWithEnv

54desugarImportsWithEnv externs modules = do

55desugarImportsWithEnv externs modules = do

55 env <- silence $ foldM externsEnv primEnv externs

56 env <- silence $ foldM externsEnv primEnv externs

56 modules' <- traverse updateExportRefs modules

57 modules' <- traverse updateExportRefs modules

57− (modules'', env') <- foldM updateEnv ([], env) modules'

58+ (modules'', env') <- first reverse <$> foldM updateEnv ([], env) modules'

58 (env',) <$> traverse (renameInModule' env') modules''

59 (env',) <$> traverse (renameInModule' env') modules''

59 where

60 where

60 silence :: m a -> m a

61 silence :: m a -> m a

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

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

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

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

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

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

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

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

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

172 updateDecl s d = return (s, d)

173 updateDecl s d = return (s, d)

173

174

174 updateValue

175 updateValue

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

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

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

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

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

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

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

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

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

206 updateBinder s (TypedBinder t b) = do

209 updateBinder s (TypedBinder t b) = do

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

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

208 t' <- updateTypesEverywhere span' t

211 t' <- updateTypesEverywhere span' t

src/Language/PureScript/Sugar/ObjectWildcards.hs+36−15

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

1{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE PatternGuards #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

3

4

4module Language.PureScript.Sugar.ObjectWildcards (

5module Language.PureScript.Sugar.ObjectWildcards (

@@ -8,12 +9,11 @@ module Language.PureScript.Sugar.ObjectWildcards (

8import Prelude ()

9import Prelude ()

9import Prelude.Compat

10import Prelude.Compat

10

11

11−import Control.Arrow (second)

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

13import Control.Monad.Supply.Class

14

15import Data.List (partition)

16−import Data.Maybe (isJust, fromJust, catMaybes)

16+import Data.Maybe (catMaybes)

17

18import Language.PureScript.AST

19import Language.PureScript.Errors

@@ -24,30 +24,51 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma

24 where

25

26 desugarDecl :: Declaration -> m Declaration

27+ desugarDecl (PositionedDeclaration pos com d) = rethrowWithPosition pos $ PositionedDeclaration pos com <$> desugarDecl d

28+ desugarDecl other = f other

29+ where

27− (desugarDecl, _, _) = everywhereOnValuesM return desugarExpr return

30+ (f, _, _) = everywhereOnValuesTopDownM return desugarExpr return

28

31

29 desugarExpr :: Expr -> m Expr

32 desugarExpr :: Expr -> m Expr

30− desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps

33+ desugarExpr AnonymousArgument = throwError . errorMessage $ IncorrectAnonymousArgument

31− desugarExpr (ObjectUpdater (Just obj) ps) = wrapLambda (ObjectUpdate obj) ps

34+ desugarExpr (Parens b)

32− desugarExpr (ObjectUpdater Nothing ps) = do

35+ | b' <- stripPositionInfo b

36+ , BinaryNoParens op val u <- b'

37+ , isAnonymousArgument u = return $ OperatorSection op (Left val)

38+ | b' <- stripPositionInfo b

39+ , BinaryNoParens op u val <- b'

40+ , isAnonymousArgument u = return $ OperatorSection op (Right val)

41+ desugarExpr (ObjectLiteral ps) = wrapLambda ObjectLiteral ps

42+ desugarExpr (ObjectUpdate u ps) | isAnonymousArgument u = do

33 obj <- freshIdent'

43 obj <- freshIdent'

34 Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps

44 Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps

35− desugarExpr (ObjectGetter prop) = do

45+ desugarExpr (ObjectUpdate obj ps) = wrapLambda (ObjectUpdate obj) ps

46+ desugarExpr (Accessor prop u) | isAnonymousArgument u = do

36 arg <- freshIdent'

47 arg <- freshIdent'

37 return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg)))

48 return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg)))

38 desugarExpr e = return e

49 desugarExpr e = return e

39

50

40− wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Maybe Expr)] -> m Expr

51+ wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Expr)] -> m Expr

41 wrapLambda mkVal ps =

52 wrapLambda mkVal ps =

42− let (props, args) = partition (isJust . snd) ps

53+ let (args, props) = partition (isAnonymousArgument . snd) ps

43 in if null args

54 in if null args

44− then return . mkVal $ second fromJust `map` props

55+ then return $ mkVal props

45 else do

56 else do

46 (args', ps') <- unzip <$> mapM mkProp ps

57 (args', ps') <- unzip <$> mapM mkProp ps

47 return $ foldr (Abs . Left) (mkVal ps') (catMaybes args')

58 return $ foldr (Abs . Left) (mkVal ps') (catMaybes args')

48

59

60+ stripPositionInfo :: Expr -> Expr

61+ stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e

62+ stripPositionInfo e = e

63+

64+ isAnonymousArgument :: Expr -> Bool

65+ isAnonymousArgument AnonymousArgument = True

66+ isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e

67+ isAnonymousArgument _ = False

68+

49− mkProp :: (String, Maybe Expr) -> m (Maybe Ident, (String, Expr))

69+ mkProp :: (String, Expr) -> m (Maybe Ident, (String, Expr))

50− mkProp (name, Just e) = return (Nothing, (name, e))

70+ mkProp (name, e)

51− mkProp (name, Nothing) = do

71+ | isAnonymousArgument e = do

52− arg <- freshIdent'

72+ arg <- freshIdent'

53− return (Just arg, (name, Var (Qualified Nothing arg)))

73+ return (Just arg, (name, Var (Qualified Nothing arg)))

74+ | otherwise = return (Nothing, (name, e))

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

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

20import Prelude ()

21import Prelude.Compat

22

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)

28

31

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

32

34

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

38

39

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

44

41

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'

56

71

57 where

72 where

58

73

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

61

76

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)

68

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

76

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

81

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 ]

95

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 #-}

3+

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

5+

6+import Prelude ()

7+import Prelude.Compat

8+

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 #-}

3+

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

5+

6+import Prelude ()

7+import Prelude.Compat

8+

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 #-}

3+

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

5+

6+import Prelude ()

7+import Prelude.Compat

8+

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/Sugar/TypeClasses/Deriving.hs+285−138

@@ -50,6 +50,14 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] Derived

50 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty

51 , mn == fromMaybe mn mn'

52 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args

53+ | className == Qualified (Just (ModuleName [ ProperName "Prelude" ])) (ProperName "Eq")

54+ , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty

55+ , mn == fromMaybe mn mn'

56+ = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn ds tyCon

57+ | className == Qualified (Just (ModuleName [ ProperName "Prelude" ])) (ProperName "Ord")

58+ , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty

59+ , mn == fromMaybe mn mn'

60+ = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon

53deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)

61deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)

54 = throwError . errorMessage $ CannotDerive className tys

62 = throwError . errorMessage $ CannotDerive className tys

55deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d

63deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d

@@ -74,21 +82,279 @@ typesProxy :: ModuleName

74typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]

82typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]

75

83

76deriveGeneric

84deriveGeneric

77− :: (Functor m, MonadError MultipleErrors m, MonadSupply m)

85+ :: forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m)

78 => ModuleName

86 => ModuleName

79 -> [Declaration]

87 -> [Declaration]

80 -> ProperName 'TypeName

88 -> ProperName 'TypeName

81 -> [Type]

89 -> [Type]

82 -> m [Declaration]

90 -> m [Declaration]

83−deriveGeneric mn ds tyConNm args = do

91+deriveGeneric mn ds tyConNm dargs = do

84 tyCon <- findTypeDecl tyConNm ds

92 tyCon <- findTypeDecl tyConNm ds

85− toSpine <- mkSpineFunction mn tyCon

93+ toSpine <- mkSpineFunction tyCon

86− fromSpine <- mkFromSpineFunction mn tyCon

94+ fromSpine <- mkFromSpineFunction tyCon

87− let toSignature = mkSignatureFunction mn tyCon args

95+ let toSignature = mkSignatureFunction tyCon dargs

88 return [ ValueDeclaration (Ident C.toSpine) Public [] (Right toSpine)

96 return [ ValueDeclaration (Ident C.toSpine) Public [] (Right toSpine)

89 , ValueDeclaration (Ident C.fromSpine) Public [] (Right fromSpine)

97 , ValueDeclaration (Ident C.fromSpine) Public [] (Right fromSpine)

90 , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)

98 , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)

91 ]

99 ]

100+ where

101+ mkSpineFunction :: Declaration -> m Expr

102+ mkSpineFunction (DataDeclaration _ _ _ args) = do

103+ x <- freshIdent'

104+ lamCase x <$> mapM mkCtorClause args

105+ where

106+ prodConstructor :: Expr -> Expr

107+ prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd")))

108+

109+ recordConstructor :: Expr -> Expr

110+ recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord")))

111+

112+ mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative

113+ mkCtorClause (ctorName, tys) = do

114+ idents <- replicateM (length tys) freshIdent'

115+ return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))

116+ where

117+ caseResult idents =

118+ App (prodConstructor (StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName))

119+ . ArrayLiteral

120+ $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys

121+

122+ toSpineFun :: Expr -> Type -> Expr

123+ toSpineFun i r | Just rec <- objectType r =

124+ lamNull . recordConstructor . ArrayLiteral .

125+ map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])

126+ $ decomposeRec rec

127+ toSpineFun i _ = lamNull $ App (mkGenVar (Ident C.toSpine)) i

128+ mkSpineFunction (PositionedDeclaration _ _ d) = mkSpineFunction d

129+ mkSpineFunction _ = internalError "mkSpineFunction: expected DataDeclaration"

130+

131+ mkSignatureFunction :: Declaration -> [Type] -> Expr

132+ mkSignatureFunction (DataDeclaration _ name tyArgs args) classArgs = lamNull . mkSigProd $ map mkProdClause args

133+ where

134+ mkSigProd :: [Expr] -> Expr

135+ mkSigProd = App (App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd")))

136+ (StringLiteral (showQualified runProperName (Qualified (Just mn) name)))

137+ ) . ArrayLiteral

138+

139+ mkSigRec :: [Expr] -> Expr

140+ mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral

141+

142+ proxy :: Type -> Type

143+ proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy")))

144+

145+ mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr

146+ mkProdClause (ctorName, tys) =

147+ ObjectLiteral

148+ [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))

149+ , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)

150+ ]

151+

152+ mkProductSignature :: Type -> Expr

153+ mkProductSignature r | Just rec <- objectType r =

154+ lamNull . mkSigRec $ [ ObjectLiteral [ ("recLabel", StringLiteral str)

155+ , ("recValue", mkProductSignature typ)

156+ ]

157+ | (str, typ) <- decomposeRec rec

158+ ]

159+ mkProductSignature typ = lamNull $ App (mkGenVar (Ident C.toSignature))

160+ (TypedValue False (mkGenVar (Ident "anyProxy")) (proxy typ))

161+ instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs)

162+ mkSignatureFunction (PositionedDeclaration _ _ d) classArgs = mkSignatureFunction d classArgs

163+ mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration"

164+

165+ mkFromSpineFunction :: Declaration -> m Expr

166+ mkFromSpineFunction (DataDeclaration _ _ _ args) = do

167+ x <- freshIdent'

168+ lamCase x <$> (addCatch <$> mapM mkAlternative args)

169+ where

170+ mkJust :: Expr -> Expr

171+ mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just")))

172+

173+ mkNothing :: Expr

174+ mkNothing = Constructor (Qualified (Just dataMaybe) (ProperName "Nothing"))

175+

176+ prodBinder :: [Binder] -> Binder

177+ prodBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SProd"))

178+

179+ recordBinder :: [Binder] -> Binder

180+ recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord"))

181+

182+ mkAlternative :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative

183+ mkAlternative (ctorName, tys) = do

184+ idents <- replicateM (length tys) freshIdent'

185+ return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]]

186+ . Right

187+ $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))

188+ (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys)

189+

190+ addCatch :: [CaseAlternative] -> [CaseAlternative]

191+ addCatch = (++ [catchAll])

192+ where

193+ catchAll = CaseAlternative [NullBinder] (Right mkNothing)

194+

195+ fromSpineFun :: Expr -> Type -> Expr

196+ fromSpineFun e r

197+ | Just rec <- objectType r

198+ = App (lamCase (Ident "r") [ mkRecCase (decomposeRec rec)

199+ , CaseAlternative [NullBinder] (Right mkNothing)

200+ ])

201+ (App e (mkPrelVar (Ident "unit")))

202+ fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e (mkPrelVar (Ident "unit")))

203+

204+ mkRecCase :: [(String, Type)] -> CaseAlternative

205+ mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs)

206+ ]

207+ ]

208+ . Right

209+ $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs)

210+

211+ mkRecFun :: [(String, Type)] -> Expr

212+ mkRecFun xs = mkJust $ foldr lam recLiteral (map (Ident . fst) xs)

213+ where recLiteral = ObjectLiteral $ map (\(s,_) -> (s, mkVar (Ident s))) xs

214+ mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d

215+ mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration"

216+

217+ -- Helpers

218+

219+ liftApplicative :: Expr -> [Expr] -> Expr

220+ liftApplicative = foldl' (\x e -> App (App (mkPrelVar (Ident "apply")) x) e)

221+

222+ mkPrelVar :: Ident -> Expr

223+ mkPrelVar = mkVarMn (Just (ModuleName [ProperName C.prelude]))

224+

225+ mkGenVar :: Ident -> Expr

226+ mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic]))

227+

228+deriveEq ::

229+ forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m)

230+ => ModuleName

231+ -> [Declaration]

232+ -> ProperName 'TypeName

233+ -> m [Declaration]

234+deriveEq mn ds tyConNm = do

235+ tyCon <- findTypeDecl tyConNm ds

236+ eqFun <- mkEqFunction tyCon

237+ return [ ValueDeclaration (Ident C.eq) Public [] (Right eqFun) ]

238+ where

239+ mkEqFunction :: Declaration -> m Expr

240+ mkEqFunction (DataDeclaration _ _ _ args) = do

241+ x <- freshIdent "x"

242+ y <- freshIdent "y"

243+ lamCase2 x y <$> (addCatch <$> mapM mkCtorClause args)

244+ mkEqFunction (PositionedDeclaration _ _ d) = mkEqFunction d

245+ mkEqFunction _ = internalError "mkEqFunction: expected DataDeclaration"

246+

247+ preludeConj :: Expr -> Expr -> Expr

248+ preludeConj = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.conj)))

249+

250+ preludeEq :: Expr -> Expr -> Expr

251+ preludeEq = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.eq)))

252+

253+ addCatch :: [CaseAlternative] -> [CaseAlternative]

254+ addCatch xs

255+ | length xs /= 1 = xs ++ [catchAll]

256+ | otherwise = xs -- Avoid redundant case

257+ where

258+ catchAll = CaseAlternative [NullBinder, NullBinder] (Right (BooleanLiteral False))

259+

260+ mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative

261+ mkCtorClause (ctorName, tys) = do

262+ identsL <- replicateM (length tys) (freshIdent "l")

263+ identsR <- replicateM (length tys) (freshIdent "r")

264+ let tests = zipWith3 toEqTest (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys

265+ return $ CaseAlternative [caseBinder identsL, caseBinder identsR] (Right (conjAll tests))

266+ where

267+ caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)

268+

269+ conjAll :: [Expr] -> Expr

270+ conjAll [] = BooleanLiteral True

271+ conjAll xs = foldl1 preludeConj xs

272+

273+ toEqTest :: Expr -> Expr -> Type -> Expr

274+ toEqTest l r ty | Just rec <- objectType ty =

275+ conjAll

276+ . map (\(str, typ) -> toEqTest (Accessor str l) (Accessor str r) typ)

277+ $ decomposeRec rec

278+ toEqTest l r _ = preludeEq l r

279+

280+deriveOrd ::

281+ forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m)

282+ => ModuleName

283+ -> [Declaration]

284+ -> ProperName 'TypeName

285+ -> m [Declaration]

286+deriveOrd mn ds tyConNm = do

287+ tyCon <- findTypeDecl tyConNm ds

288+ compareFun <- mkCompareFunction tyCon

289+ return [ ValueDeclaration (Ident C.compare) Public [] (Right compareFun) ]

290+ where

291+ mkCompareFunction :: Declaration -> m Expr

292+ mkCompareFunction (DataDeclaration _ _ _ args) = do

293+ x <- freshIdent "x"

294+ y <- freshIdent "y"

295+ lamCase2 x y <$> (addCatch . concat <$> mapM mkCtorClauses (splitLast args))

296+ mkCompareFunction (PositionedDeclaration _ _ d) = mkCompareFunction d

297+ mkCompareFunction _ = internalError "mkCompareFunction: expected DataDeclaration"

298+

299+ splitLast :: [a] -> [(a, Bool)]

300+ splitLast [] = []

301+ splitLast [x] = [(x, True)]

302+ splitLast (x : xs) = (x, False) : splitLast xs

303+

304+ addCatch :: [CaseAlternative] -> [CaseAlternative]

305+ addCatch xs

306+ | null xs = [catchAll] -- No type constructors

307+ | otherwise = xs

308+ where

309+ catchAll = CaseAlternative [NullBinder, NullBinder] (Right (preludeCtor "EQ"))

310+

311+ preludeCtor :: String -> Expr

312+ preludeCtor = Constructor . Qualified (Just (ModuleName [ProperName C.prelude])) . ProperName

313+

314+ preludeCompare :: Expr -> Expr -> Expr

315+ preludeCompare = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.compare)))

316+

317+ mkCtorClauses :: ((ProperName 'ConstructorName, [Type]), Bool) -> m [CaseAlternative]

318+ mkCtorClauses ((ctorName, tys), isLast) = do

319+ identsL <- replicateM (length tys) (freshIdent "l")

320+ identsR <- replicateM (length tys) (freshIdent "r")

321+ let tests = zipWith3 toOrdering (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys

322+ extras | not isLast = [ CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder)

323+ , NullBinder

324+ ]

325+ (Right (preludeCtor "LT"))

326+ , CaseAlternative [ NullBinder

327+ , ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder)

328+ ]

329+ (Right (preludeCtor "GT"))

330+ ]

331+ | otherwise = []

332+ return $ CaseAlternative [ caseBinder identsL

333+ , caseBinder identsR

334+ ]

335+ (Right (appendAll tests))

336+ : extras

337+

338+ where

339+ caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)

340+

341+ appendAll :: [Expr] -> Expr

342+ appendAll [] = preludeCtor "EQ"

343+ appendAll [x] = x

344+ appendAll (x : xs) = Case [x] [ CaseAlternative [ ConstructorBinder (Qualified (Just (ModuleName [ProperName C.prelude])) (ProperName "LT")) [] ]

345+ (Right (preludeCtor "LT"))

346+ , CaseAlternative [ ConstructorBinder (Qualified (Just (ModuleName [ProperName C.prelude])) (ProperName "GT")) [] ]

347+ (Right (preludeCtor "GT"))

348+ , CaseAlternative [ NullBinder ]

349+ (Right (appendAll xs))

350+ ]

351+

352+ toOrdering :: Expr -> Expr -> Type -> Expr

353+ toOrdering l r ty | Just rec <- objectType ty =

354+ appendAll

355+ . map (\(str, typ) -> toOrdering (Accessor str l) (Accessor str r) typ)

356+ $ decomposeRec rec

357+ toOrdering l r _ = preludeCompare l r

92

358

93findTypeDecl

359findTypeDecl

94 :: (Functor m, MonadError MultipleErrors m)

360 :: (Functor m, MonadError MultipleErrors m)

@@ -102,148 +368,29 @@ findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType

102 isTypeDecl (PositionedDeclaration _ _ d) = isTypeDecl d

368 isTypeDecl (PositionedDeclaration _ _ d) = isTypeDecl d

103 isTypeDecl _ = False

369 isTypeDecl _ = False

104

370

105−mkSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr

106−mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorClause args

107− where

108− prodConstructor :: Expr -> Expr

109− prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd")))

110−

111− recordConstructor :: Expr -> Expr

112− recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord")))

113−

114− mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative

115− mkCtorClause (ctorName, tys) = do

116− idents <- replicateM (length tys) freshIdent'

117− return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))

118− where

119− caseResult idents =

120− App (prodConstructor (StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName))

121− . ArrayLiteral

122− $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys

123−

124− toSpineFun :: Expr -> Type -> Expr

125− toSpineFun i r | Just rec <- objectType r =

126− lamNull . recordConstructor . ArrayLiteral .

127− map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])

128− $ decomposeRec rec

129− toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i

130−mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d

131−mkSpineFunction _ _ = internalError "mkSpineFunction: expected DataDeclaration"

132−

133−mkSignatureFunction :: ModuleName -> Declaration -> [Type] -> Expr

134−mkSignatureFunction mn (DataDeclaration _ name tyArgs args) classArgs = lamNull . mkSigProd $ map mkProdClause args

135− where

136− mkSigProd :: [Expr] -> Expr

137− mkSigProd = App (App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd")))

138− (StringLiteral (showQualified runProperName (Qualified (Just mn) name)))

139− ) . ArrayLiteral

140−

141− mkSigRec :: [Expr] -> Expr

142− mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral

143−

144− proxy :: Type -> Type

145− proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy")))

146−

147− mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr

148− mkProdClause (ctorName, tys) =

149− ObjectLiteral

150− [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))

151− , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)

152− ]

153−

154− mkProductSignature :: Type -> Expr

155− mkProductSignature r | Just rec <- objectType r =

156− lamNull . mkSigRec $ [ ObjectLiteral [ ("recLabel", StringLiteral str)

157− , ("recValue", mkProductSignature typ)

158− ]

159− | (str, typ) <- decomposeRec rec

160− ]

161− mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)

162− (TypedValue False (mkGenVar "anyProxy") (proxy typ))

163− instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs)

164−mkSignatureFunction mn (PositionedDeclaration _ _ d) classArgs = mkSignatureFunction mn d classArgs

165−mkSignatureFunction _ _ _ = internalError "mkSignatureFunction: expected DataDeclaration"

166−

167−mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr

168−mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args)

169− where

170− mkJust :: Expr -> Expr

171− mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just")))

172−

173− mkNothing :: Expr

174− mkNothing = Constructor (Qualified (Just dataMaybe) (ProperName "Nothing"))

175−

176− prodBinder :: [Binder] -> Binder

177− prodBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SProd"))

178−

179− recordBinder :: [Binder] -> Binder

180− recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord"))

181−

182− mkAlternative :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative

183− mkAlternative (ctorName, tys) = do

184− idents <- replicateM (length tys) freshIdent'

185− return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]]

186− . Right

187− $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))

188− (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys)

189−

190− addCatch :: [CaseAlternative] -> [CaseAlternative]

191− addCatch = (++ [catchAll])

192− where

193− catchAll = CaseAlternative [NullBinder] (Right mkNothing)

194−

195− fromSpineFun e r

196− | Just rec <- objectType r

197− = App (lamCase "r" [ mkRecCase (decomposeRec rec)

198− , CaseAlternative [NullBinder] (Right mkNothing)

199− ])

200− (App e (mkPrelVar "unit"))

201−

202− fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit"))

203−

204− mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs)

205− ]

206− ]

207− . Right

208− $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar x)) y) rs)

209−

210− mkRecFun :: [(String, Type)] -> Expr

211− mkRecFun xs = mkJust $ foldr lam recLiteral (map fst xs)

212− where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs

213−mkFromSpineFunction mn (PositionedDeclaration _ _ d) = mkFromSpineFunction mn d

214−mkFromSpineFunction _ _ = internalError "mkFromSpineFunction: expected DataDeclaration"

215−

216−-- Helpers

217−

218−objectType :: Type -> Maybe Type

219−objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec) = Just rec

220−objectType _ = Nothing

221−

222−lam :: String -> Expr -> Expr

371+lam :: Ident -> Expr -> Expr

223−lam s = Abs (Left (Ident s))

372+lam = Abs . Left

224

373

225lamNull :: Expr -> Expr

374lamNull :: Expr -> Expr

226−lamNull = lam "$q"

375+lamNull = lam (Ident "$q") -- TODO: use GenIdent

227

376

228−lamCase :: String -> [CaseAlternative] -> Expr

377+lamCase :: Ident -> [CaseAlternative] -> Expr

229lamCase s = lam s . Case [mkVar s]

378lamCase s = lam s . Case [mkVar s]

230

379

231−liftApplicative :: Expr -> [Expr] -> Expr

380+lamCase2 :: Ident -> Ident -> [CaseAlternative] -> Expr

232−liftApplicative = foldl' (\x e -> App (App (mkPrelVar "apply") x) e)

381+lamCase2 s t = lam s . lam t . Case [mkVar s, mkVar t]

233

382

234−mkVarMn :: Maybe ModuleName -> String -> Expr

383+mkVarMn :: Maybe ModuleName -> Ident -> Expr

235−mkVarMn mn s = Var (Qualified mn (Ident s))

384+mkVarMn mn = Var . Qualified mn

236

385

237−mkVar :: String -> Expr

386+mkVar :: Ident -> Expr

238mkVar = mkVarMn Nothing

387mkVar = mkVarMn Nothing

239

388

240−mkPrelVar :: String -> Expr

389+objectType :: Type -> Maybe Type

241−mkPrelVar = mkVarMn (Just (ModuleName [ProperName C.prelude]))

390+objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec) = Just rec

242−

391+objectType _ = Nothing

243−mkGenVar :: String -> Expr

244−mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic]))

245

392

246decomposeRec :: Type -> [(String, Type)]

393decomposeRec :: Type -> [(String, Type)]

247decomposeRec = sortBy (comparing fst) . go

394decomposeRec = sortBy (comparing fst) . go

248− where go (RCons str typ typs) = (str, typ) : decomposeRec typs

395+ where go (RCons str typ typs) = (str, typ) : decomposeRec typs

249− go _ = []

396+ go _ = []

src/Language/PureScript/TypeChecker.hs+45−22

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

19import Language.PureScript.TypeChecker.Synonyms as T

20

21import Data.Maybe

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

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

23import Data.Foldable (for_, traverse_)

24

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

32

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

41

42addDataType

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

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

230 let args' = args `withKinds` kind

231 addTypeSynonym moduleName name args' ty kind

232 return $ TypeSynonymDeclaration name args ty

233− go (TypeDeclaration{}) = internalError "Type declarations should have been removed"

233+ go TypeDeclaration{} = internalError "Type declarations should have been removed"

234 go (ValueDeclaration name nameKind [] (Right val)) =

235 warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do

236 valueIsNotDefined moduleName name

237 [(_, (val', ty))] <- typesOf moduleName [(name, val)]

238 addValue moduleName name ty nameKind

239 return $ ValueDeclaration name nameKind [] $ Right val'

240− go (ValueDeclaration{}) = internalError "Binders were not desugared"

240+ go ValueDeclaration{} = internalError "Binders were not desugared"

241 go (BindingGroupDeclaration vals) =

242 warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do

243 for_ (map (\(ident, _, _) -> ident) vals) $ \name ->

@@ -264,8 +264,8 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

264 Just _ -> throwError . errorMessage $ RedefinedIdent name

265 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) })

266 return d

267− go (d@(FixityDeclaration{})) = return d

267+ go (d@FixityDeclaration{}) = return d

268− go (d@(ImportDeclaration{})) = return d

268+ go (d@ImportDeclaration{}) = return d

269 go (d@(TypeClassDeclaration pn args implies tys)) = do

270 addTypeClass moduleName pn args implies tys

271 return d

@@ -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− when (not $ any (== ValueRef alias) 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.

stack-lts-3.yaml+1−1

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

1flags: {}

2packages:

3- '.'

4−extra-deps:

4+extra-deps: []

5resolver: lts-3.6

tests/Main.hs+8−204

@@ -16,171 +16,26 @@

16{-# LANGUAGE TupleSections #-}

17{-# LANGUAGE FlexibleInstances #-}

18

19−-- Failing tests can specify the kind of error that should be thrown with a

20−-- @shouldFailWith declaration. For example:

21−--

22−-- "-- @shouldFailWith TypesDoNotUnify"

23−--

24−-- will cause the test to fail unless that module fails to compile with exactly

25−-- one TypesDoNotUnify error.

26−--

27−-- If a module is expected to produce multiple type errors, then use multiple

28−-- @shouldFailWith lines; for example:

29−--

30−-- -- @shouldFailWith TypesDoNotUnify

31−-- -- @shouldFailWith TypesDoNotUnify

32−-- -- @shouldFailWith TransitiveExportError

33−--

34−

35module Main (main) where

19module Main (main) where

36

20

37import Prelude ()

21import Prelude ()

38import Prelude.Compat

22import Prelude.Compat

39

23

40−import qualified Language.PureScript as P

24+import qualified TestCompiler

41−import qualified Language.PureScript.CodeGen.JS as J

42−import qualified Language.PureScript.CoreFn as CF

43−import qualified Language.PureScript.Docs as Docs

44−

45−import Data.Char (isSpace)

46−import Data.Maybe (mapMaybe, fromMaybe)

47−import Data.List (isSuffixOf, sort, stripPrefix)

48−import Data.Time.Clock (UTCTime())

49−

50−import qualified Data.Map as M

51−

52−import Control.Monad

53−import Control.Monad.IO.Class (liftIO)

54−import Control.Arrow ((>>>))

55−

56−import Control.Monad.Reader

57−import Control.Monad.Writer.Strict

58−import Control.Monad.Trans.Maybe

59−import Control.Monad.Trans.Except

60−import Control.Monad.Error.Class

61−

62−import System.Exit

63−import System.Process

64−import System.FilePath

65−import System.Directory

66−import System.IO.UTF8

67−import qualified System.Info

68−import qualified System.FilePath.Glob as Glob

69−

70−import Text.Parsec (ParseError)

71−

72−import TestsSetup

73−import TestPscPublish

25+import qualified TestPscPublish

74import qualified TestDocs

26import qualified TestDocs

75−

27+import qualified TestPsci

76−modulesDir :: FilePath

77−modulesDir = ".test_modules" </> "node_modules"

78−

79−makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make

80−makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False)

81− { P.getInputTimestamp = getInputTimestamp

82− , P.getOutputTimestamp = getOutputTimestamp

83− }

84− where

85− getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))

86− getInputTimestamp mn

87− | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever)

88− | otherwise = return (Left P.RebuildAlways)

89− where

90− isSupportModule = flip elem supportModules

91−

92− getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)

93− getOutputTimestamp mn = do

94− let filePath = modulesDir </> P.runModuleName mn

95− exists <- liftIO $ doesDirectoryExist filePath

96− return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing)

97−

98−readInput :: [FilePath] -> IO [(FilePath, String)]

99−readInput inputFiles = forM inputFiles $ \inputFile -> do

100− text <- readUTF8File inputFile

101− return (inputFile, text)

102−

103−type TestM = WriterT [(FilePath, String)] IO

104−

105−runTest :: P.Make a -> IO (Either P.MultipleErrors a)

106−runTest = fmap fst . P.runMake P.defaultOptions

107−

108−compile :: [FilePath] -> M.Map P.ModuleName FilePath -> IO (Either P.MultipleErrors P.Environment)

109−compile inputFiles foreigns = runTest $ do

110− fs <- liftIO $ readInput inputFiles

111− ms <- P.parseModulesFromFiles id fs

112− P.make (makeActions foreigns) (map snd ms)

113−

114−assert :: [FilePath] ->

115− M.Map P.ModuleName FilePath ->

116− (Either P.MultipleErrors P.Environment -> IO (Maybe String)) ->

117− TestM ()

118−assert inputFiles foreigns f = do

119− e <- liftIO $ compile inputFiles foreigns

120− maybeErr <- liftIO $ f e

121− case maybeErr of

122− Just err -> tell [(last inputFiles, err)]

123− Nothing -> return ()

124−

125−assertCompiles :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()

126−assertCompiles inputFiles foreigns = do

127− liftIO . putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully"

128− assert inputFiles foreigns $ \e ->

129− case e of

130− Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs

131− Right _ -> do

132− process <- findNodeProcess

133− let entryPoint = modulesDir </> "index.js"

134− writeFile entryPoint "require('Main').main()"

135− result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process

136− case result of

137− Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing

138− Just (ExitFailure _, _, err) -> return $ Just err

139− Nothing -> return $ Just "Couldn't find node.js executable"

140−

141−assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()

142−assertDoesNotCompile inputFiles foreigns = do

143− let testFile = last inputFiles

144− liftIO . putStrLn $ "Assert " ++ testFile ++ " does not compile"

145− shouldFailWith <- getShouldFailWith testFile

146− assert inputFiles foreigns $ \e ->

147− case e of

148− Left errs -> do

149− putStrLn (P.prettyPrintMultipleErrors False errs)

150− return $ if null shouldFailWith

151− then Just $ "shouldFailWith declaration is missing (errors were: "

152− ++ show (map P.errorCode (P.runMultipleErrors errs))

153− ++ ")"

154− else checkShouldFailWith shouldFailWith errs

155− Right _ ->

156− return $ Just "Should not have compiled"

157−

158− where

159− getShouldFailWith =

160− readUTF8File

161− >>> liftIO

162− >>> fmap ( lines

163− >>> mapMaybe (stripPrefix "-- @shouldFailWith ")

164− >>> map trim

165− )

166−

167− checkShouldFailWith expected errs =

168− let actual = map P.errorCode $ P.runMultipleErrors errs

169− in if sort expected == sort actual

170− then Nothing

171− else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual

172−

173− trim =

174− dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse

175

28

176main :: IO ()

29main :: IO ()

177main = do

30main = do

178 heading "Main compiler test suite"

31 heading "Main compiler test suite"

179− testCompiler

32+ TestCompiler.main

180 heading "Documentation test suite"

33 heading "Documentation test suite"

181 TestDocs.main

34 TestDocs.main

182− -- heading "psc-publish test suite"

35+ heading "psc-publish test suite"

183− -- testPscPublish

36+ TestPscPublish.main

37+ heading "psci test suite"

38+ TestPsci.main

184

39

185 where

40 where

186 heading msg = do

41 heading msg = do

@@ -189,54 +44,3 @@ main = do

189 putStrLn $ "# " ++ msg

44 putStrLn $ "# " ++ msg

190 putStrLn $ replicate 79 '#'

45 putStrLn $ replicate 79 '#'

191 putStrLn ""

46 putStrLn ""

192−

193−testCompiler :: IO ()

194−testCompiler = do

195− fetchSupportCode

196− cwd <- getCurrentDirectory

197−

198− let supportDir = cwd </> "tests" </> "support" </> "flattened"

199− let supportFiles ext = Glob.globDir1 (Glob.compile ("*." ++ ext)) supportDir

200−

201− supportPurs <- supportFiles "purs"

202− supportJS <- supportFiles "js"

203−

204− foreignFiles <- forM supportJS (\f -> (f,) <$> readUTF8File f)

205− Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles

206−

207− let passing = cwd </> "examples" </> "passing"

208− passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passing

209− let failing = cwd </> "examples" </> "failing"

210− failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing

211−

212− failures <- execWriterT $ do

213− forM_ passingTestCases $ \inputFile ->

214− assertCompiles (supportPurs ++ [passing </> inputFile]) foreigns

215− forM_ failingTestCases $ \inputFile ->

216− assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns

217−

218− if null failures

219− then pure ()

220− else do

221− putStrLn "Failures:"

222− forM_ failures $ \(fp, err) ->

223− let fp' = fromMaybe fp $ stripPrefix (failing ++ [pathSeparator]) fp

224− in putStrLn $ fp' ++ ": " ++ err

225− exitFailure

226−

227−testPscPublish :: IO ()

228−testPscPublish = do

229− testPackage "tests/support/prelude"

230−

231−

232−supportModules :: [String]

233−supportModules =

234− [ "Control.Monad.Eff.Class"

235− , "Control.Monad.Eff.Console"

236− , "Control.Monad.Eff"

237− , "Control.Monad.Eff.Unsafe"

238− , "Control.Monad.ST"

239− , "Data.Function"

240− , "Prelude"

241− , "Test.Assert"

242− ]

tests/TestCompiler.hsnew file+194

@@ -0,0 +1,194 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DoAndIfThenElse #-}

3+{-# LANGUAGE TupleSections #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+

6+module TestCompiler where

7+

8+-- Failing tests can specify the kind of error that should be thrown with a

9+-- @shouldFailWith declaration. For example:

10+--

11+-- "-- @shouldFailWith TypesDoNotUnify"

12+--

13+-- will cause the test to fail unless that module fails to compile with exactly

14+-- one TypesDoNotUnify error.

15+--

16+-- If a module is expected to produce multiple type errors, then use multiple

17+-- @shouldFailWith lines; for example:

18+--

19+-- -- @shouldFailWith TypesDoNotUnify

20+-- -- @shouldFailWith TypesDoNotUnify

21+-- -- @shouldFailWith TransitiveExportError

22+

23+import Prelude ()

24+import Prelude.Compat

25+

26+import qualified Language.PureScript as P

27+

28+import Data.Char (isSpace)

29+import Data.Maybe (mapMaybe, fromMaybe)

30+import Data.List (isSuffixOf, sort, stripPrefix)

31+import Data.Time.Clock (UTCTime())

32+

33+import qualified Data.Map as M

34+

35+import Control.Monad

36+import Control.Arrow ((>>>))

37+

38+import Control.Monad.Reader

39+import Control.Monad.Writer.Strict

40+import Control.Monad.Trans.Except

41+

42+import System.Exit

43+import System.Process hiding (cwd)

44+import System.FilePath

45+import System.Directory

46+import System.IO.UTF8

47+import qualified System.FilePath.Glob as Glob

48+

49+import TestUtils

50+

51+main :: IO ()

52+main = do

53+ cwd <- getCurrentDirectory

54+

55+ let supportDir = cwd </> "tests" </> "support" </> "flattened"

56+ let supportFiles ext = Glob.globDir1 (Glob.compile ("*." ++ ext)) supportDir

57+

58+ supportPurs <- supportFiles "purs"

59+ supportJS <- supportFiles "js"

60+

61+ foreignFiles <- forM supportJS (\f -> (f,) <$> readUTF8File f)

62+ Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles

63+

64+ let passing = cwd </> "examples" </> "passing"

65+ passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passing

66+ let failing = cwd </> "examples" </> "failing"

67+ failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing

68+

69+ failures <- execWriterT $ do

70+ forM_ passingTestCases $ \inputFile ->

71+ assertCompiles (supportPurs ++ [passing </> inputFile]) foreigns

72+ forM_ failingTestCases $ \inputFile ->

73+ assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns

74+

75+ if null failures

76+ then pure ()

77+ else do

78+ putStrLn "Failures:"

79+ forM_ failures $ \(fp, err) ->

80+ let fp' = fromMaybe fp $ stripPrefix (failing ++ [pathSeparator]) fp

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

82+ exitFailure

83+

84+modulesDir :: FilePath

85+modulesDir = ".test_modules" </> "node_modules"

86+

87+makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make

88+makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False)

89+ { P.getInputTimestamp = getInputTimestamp

90+ , P.getOutputTimestamp = getOutputTimestamp

91+ }

92+ where

93+ getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))

94+ getInputTimestamp mn

95+ | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever)

96+ | otherwise = return (Left P.RebuildAlways)

97+ where

98+ isSupportModule = flip elem supportModules

99+

100+ getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)

101+ getOutputTimestamp mn = do

102+ let filePath = modulesDir </> P.runModuleName mn

103+ exists <- liftIO $ doesDirectoryExist filePath

104+ return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing)

105+

106+readInput :: [FilePath] -> IO [(FilePath, String)]

107+readInput inputFiles = forM inputFiles $ \inputFile -> do

108+ text <- readUTF8File inputFile

109+ return (inputFile, text)

110+

111+type TestM = WriterT [(FilePath, String)] IO

112+

113+runTest :: P.Make a -> IO (Either P.MultipleErrors a)

114+runTest = fmap fst . P.runMake P.defaultOptions

115+

116+compile :: [FilePath] -> M.Map P.ModuleName FilePath -> IO (Either P.MultipleErrors P.Environment)

117+compile inputFiles foreigns = runTest $ do

118+ fs <- liftIO $ readInput inputFiles

119+ ms <- P.parseModulesFromFiles id fs

120+ P.make (makeActions foreigns) (map snd ms)

121+

122+assert :: [FilePath] ->

123+ M.Map P.ModuleName FilePath ->

124+ (Either P.MultipleErrors P.Environment -> IO (Maybe String)) ->

125+ TestM ()

126+assert inputFiles foreigns f = do

127+ e <- liftIO $ compile inputFiles foreigns

128+ maybeErr <- liftIO $ f e

129+ case maybeErr of

130+ Just err -> tell [(last inputFiles, err)]

131+ Nothing -> return ()

132+

133+assertCompiles :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()

134+assertCompiles inputFiles foreigns = do

135+ liftIO . putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully"

136+ assert inputFiles foreigns $ \e ->

137+ case e of

138+ Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs

139+ Right _ -> do

140+ process <- findNodeProcess

141+ let entryPoint = modulesDir </> "index.js"

142+ writeFile entryPoint "require('Main').main()"

143+ result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process

144+ case result of

145+ Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing

146+ Just (ExitFailure _, _, err) -> return $ Just err

147+ Nothing -> return $ Just "Couldn't find node.js executable"

148+

149+assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()

150+assertDoesNotCompile inputFiles foreigns = do

151+ let testFile = last inputFiles

152+ liftIO . putStrLn $ "Assert " ++ testFile ++ " does not compile"

153+ shouldFailWith <- getShouldFailWith testFile

154+ assert inputFiles foreigns $ \e ->

155+ case e of

156+ Left errs -> do

157+ putStrLn (P.prettyPrintMultipleErrors False errs)

158+ return $ if null shouldFailWith

159+ then Just $ "shouldFailWith declaration is missing (errors were: "

160+ ++ show (map P.errorCode (P.runMultipleErrors errs))

161+ ++ ")"

162+ else checkShouldFailWith shouldFailWith errs

163+ Right _ ->

164+ return $ Just "Should not have compiled"

165+

166+ where

167+ getShouldFailWith =

168+ readUTF8File

169+ >>> liftIO

170+ >>> fmap ( lines

171+ >>> mapMaybe (stripPrefix "-- @shouldFailWith ")

172+ >>> map trim

173+ )

174+

175+ checkShouldFailWith expected errs =

176+ let actual = map P.errorCode $ P.runMultipleErrors errs

177+ in if sort expected == sort actual

178+ then Nothing

179+ else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual

180+

181+ trim =

182+ dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse

183+

184+supportModules :: [String]

185+supportModules =

186+ [ "Control.Monad.Eff.Class"

187+ , "Control.Monad.Eff.Console"

188+ , "Control.Monad.Eff"

189+ , "Control.Monad.Eff.Unsafe"

190+ , "Control.Monad.ST"

191+ , "Data.Function"

192+ , "Prelude"

193+ , "Test.Assert"

194+ ]

tests/TestDocs.hs+50−13

@@ -9,21 +9,17 @@ import Prelude.Compat

9

10import Data.Version (Version(..))

11

12−import Control.Monad hiding (forM_)

12+import Data.Monoid

13−import Control.Applicative

14−import Control.Arrow

15import Data.Maybe (fromMaybe)

13import Data.Maybe (fromMaybe)

16import Data.List ((\\))

14import Data.List ((\\))

17import Data.Foldable

15import Data.Foldable

18−import Data.Traversable

19import System.Exit

16import System.Exit

20−import qualified Text.Parsec as Parsec

21

17

22import qualified Language.PureScript as P

18import qualified Language.PureScript as P

23import qualified Language.PureScript.Docs as Docs

19import qualified Language.PureScript.Docs as Docs

24import qualified Language.PureScript.Publish as Publish

20import qualified Language.PureScript.Publish as Publish

25

21

26−import qualified TestPscPublish

22+import TestUtils

27

23

28publishOpts :: Publish.PublishOptions

24publishOpts :: Publish.PublishOptions

29publishOpts = Publish.defaultPublishOptions

25publishOpts = Publish.defaultPublishOptions

@@ -34,10 +30,10 @@ publishOpts = Publish.defaultPublishOptions

34

30

35main :: IO ()

31main :: IO ()

36main = do

32main = do

37− TestPscPublish.pushd "examples/docs" $ do

33+ pushd "examples/docs" $ do

38 Docs.Package{..} <- Publish.preparePackage publishOpts

34 Docs.Package{..} <- Publish.preparePackage publishOpts

39− forM_ testCases $ \(mn, pragmas) ->

35+ forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) ->

40− let mdl = takeJust ("module not found in docs: " ++ mn)

36+ let mdl = takeJust ("module not found in docs: " ++ P.runModuleName mn)

41 (find ((==) mn . Docs.modName) pkgModules)

37 (find ((==) mn . Docs.modName) pkgModules)

42 in forM_ pragmas (flip runAssertionIO mdl)

38 in forM_ pragmas (flip runAssertionIO mdl)

43

39

@@ -56,8 +52,16 @@ data Assertion

56 -- | Assert that a particular declaration has a particular type class

52 -- | Assert that a particular declaration has a particular type class

57 -- constraint.

53 -- constraint.

58 | ShouldBeConstrained P.ModuleName String String

54 | ShouldBeConstrained P.ModuleName String String

55+ -- | Assert that a particular value declaration exists, and its type

56+ -- satisfies the given predicate.

57+ | ValueShouldHaveTypeSignature P.ModuleName String (ShowFn (P.Type -> Bool))

59 deriving (Show)

58 deriving (Show)

60

59

60+newtype ShowFn a = ShowFn a

61+

62+instance Show (ShowFn a) where

63+ show _ = "<function>"

64+

61data AssertionFailure

65data AssertionFailure

62 -- | A declaration was not documented, but should have been

66 -- | A declaration was not documented, but should have been

63 = NotDocumented P.ModuleName String

67 = NotDocumented P.ModuleName String

@@ -72,6 +76,11 @@ data AssertionFailure

72 -- | A declaration had the wrong "type" (ie, value, type, type class)

76 -- | A declaration had the wrong "type" (ie, value, type, type class)

73 -- Fields: declaration title, expected "type", actual "type".

77 -- Fields: declaration title, expected "type", actual "type".

74 | WrongDeclarationType P.ModuleName String String String

78 | WrongDeclarationType P.ModuleName String String String

79+ -- | A value declaration had the wrong type (in the sense of "type

80+ -- checking"), eg, because the inferred type was used when the explicit type

81+ -- should have been.

82+ -- Fields: module name, declaration name, actual type.

83+ | ValueDeclarationWrongType P.ModuleName String P.Type

75 deriving (Show)

84 deriving (Show)

76

85

77data AssertionResult

86data AssertionResult

@@ -121,9 +130,24 @@ runAssertion assertion Docs.Module{..} =

121 Fail (WrongDeclarationType mn decl "value"

130 Fail (WrongDeclarationType mn decl "value"

122 (Docs.declInfoToString declInfo))

131 (Docs.declInfoToString declInfo))

123

132

133+ ValueShouldHaveTypeSignature mn decl (ShowFn tyPredicate) ->

134+ case find ((==) decl . Docs.declTitle) (declarationsFor mn) of

135+ Nothing ->

136+ Fail (NotDocumented mn decl)

137+ Just Docs.Declaration{..} ->

138+ case declInfo of

139+ Docs.ValueDeclaration ty ->

140+ if tyPredicate ty

141+ then Pass

142+ else Fail

143+ (ValueDeclarationWrongType mn decl ty)

144+ _ ->

145+ Fail (WrongDeclarationType mn decl "value"

146+ (Docs.declInfoToString declInfo))

147+

124 where

148 where

125 declarationsFor mn =

149 declarationsFor mn =

126− if P.runModuleName mn == modName

150+ if mn == modName

127 then modDeclarations

151 then modDeclarations

128 else fromMaybe [] (lookup mn modReExports)

152 else fromMaybe [] (lookup mn modReExports)

129

153

@@ -132,6 +156,7 @@ runAssertion assertion Docs.Module{..} =

132

156

133 childrenTitles = map Docs.cdeclTitle . Docs.declChildren

157 childrenTitles = map Docs.cdeclTitle . Docs.declChildren

134

158

159+checkConstrained :: P.Type -> String -> Bool

135checkConstrained ty tyClass =

160checkConstrained ty tyClass =

136 -- Note that we don't recurse on ConstrainedType if none of the constraints

161 -- Note that we don't recurse on ConstrainedType if none of the constraints

137 -- match; this is by design, as constraints should be moved to the front

162 -- match; this is by design, as constraints should be moved to the front

@@ -149,11 +174,11 @@ checkConstrained ty tyClass =

149

174

150runAssertionIO :: Assertion -> Docs.Module -> IO ()

175runAssertionIO :: Assertion -> Docs.Module -> IO ()

151runAssertionIO assertion mdl = do

176runAssertionIO assertion mdl = do

152− putStrLn ("In " ++ Docs.modName mdl ++ ": " ++ show assertion)

177+ putStrLn ("In " ++ P.runModuleName (Docs.modName mdl) ++ ": " ++ show assertion)

153 case runAssertion assertion mdl of

178 case runAssertion assertion mdl of

154 Pass -> pure ()

179 Pass -> pure ()

155− fail -> do

180+ Fail reason -> do

156− putStrLn (show fail)

181+ putStrLn ("Failed: " <> show reason)

157 exitFailure

182 exitFailure

158

183

159testCases :: [(String, [Assertion])]

184testCases :: [(String, [Assertion])]

@@ -226,7 +251,19 @@ testCases =

226 , ("NewOperators",

251 , ("NewOperators",

227 [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []

252 [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []

228 ])

253 ])

254+

255+ , ("ExplicitTypeSignatures",

256+ [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (ShowFn (hasTypeVar "something"))

257+ , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn ((==) P.tyInt))

258+ , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn ((==) P.tyNumber))

259+ ])

229 ]

260 ]

230

261

231 where

262 where

232 n = P.moduleNameFromString

263 n = P.moduleNameFromString

264+

265+ hasTypeVar varName =

266+ getAny . P.everythingOnTypes (<>) (Any . isVar varName)

267+

268+ isVar varName (P.TypeVar name) | varName == name = True

269+ isVar _ _ = False

tests/TestPscPublish.hs+9−8

@@ -20,13 +20,11 @@ import Data.Version

20import Language.PureScript.Docs

21import Language.PureScript.Publish

22

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

23+import TestUtils

24−pushd dir act = do

24+

25− original <- getCurrentDirectory

25+main :: IO ()

26− setCurrentDirectory dir

26+main = do

27− result <- try act :: IO (Either IOException a)

27+ testPackage "tests/support/prelude"

28− setCurrentDirectory original

29− either throwIO return result

30

28

31data TestResult

29data TestResult

32 = ParseFailed String

30 = ParseFailed String

@@ -48,6 +46,7 @@ roundTrip pkg =

48testRunOptions :: PublishOptions

46testRunOptions :: PublishOptions

49testRunOptions = defaultPublishOptions

47testRunOptions = defaultPublishOptions

50 { publishGetVersion = return testVersion

48 { publishGetVersion = return testVersion

49+ , publishWorkingTreeDirty = return ()

51 }

50 }

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

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

53

52

@@ -58,7 +57,9 @@ testPackage dir = do

58 pushd dir $ do

57 pushd dir $ do

59 r <- roundTrip <$> preparePackage testRunOptions

58 r <- roundTrip <$> preparePackage testRunOptions

60 case r of

59 case r of

61− Pass _ -> pure ()

60+ Pass _ -> do

61+ putStrLn ("psc-publish test passed for: " ++ dir)

62+ pure ()

62 other -> do

63 other -> do

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

64 putStrLn ("psc-publish tests failed on " ++ dir ++ ":")

64 putStrLn (show other)

65 putStrLn (show other)

psci/tests/Main.hs → tests/TestPsci.hsrenamed+6−9

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

1{-# LANGUAGE RecordWildCards #-}

2{-# LANGUAGE TupleSections #-}

3

4−module Main where

4+module TestPsci where

5

6import Prelude ()

7import Prelude.Compat

@@ -23,15 +23,12 @@ import Test.HUnit

23

24import qualified Language.PureScript as P

25

26−import PSCi

26+import PSCi.Module (loadAllModules)

27−import Completion

27+import PSCi.Completion

28−import Types

28+import PSCi.Types

29−

30−import TestsSetup

31

29

32main :: IO ()

30main :: IO ()

33main = do

31main = do

34− fetchSupportCode

35 Counts{..} <- runTestTT allTests

32 Counts{..} <- runTestTT allTests

36 when (errors + failures > 0) exitFailure

33 when (errors + failures > 0) exitFailure

37

34

@@ -65,8 +62,8 @@ completionTestData =

65 , ("import qualified Control.Monad.Eff.", map ("import qualified Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"])

62 , ("import qualified Control.Monad.Eff.", map ("import qualified Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"])

66

63

67 -- :load, :module should complete file paths

64 -- :load, :module should complete file paths

68− , (":l psci/tests/data/", [":l psci/tests/data/Sample.purs"])

65+ , (":l tests/support/psci/", [":l tests/support/psci/Sample.purs"])

69− , (":module psci/tests/data/", [":module psci/tests/data/Sample.purs"])

66+ , (":module tests/support/psci/", [":module tests/support/psci/Sample.purs"])

70

67

71 -- :quit, :help, :reset should not complete

68 -- :quit, :help, :reset should not complete

72 , (":help ", [])

69 , (":help ", [])

tests/common/TestsSetup.hs → tests/TestUtils.hsrenamed+23−3

@@ -10,7 +10,9 @@

10-- |

11--

12-----------------------------------------------------------------------------

13+{-# LANGUAGE ScopedTypeVariables #-}

14+

13−module TestsSetup where

15+module TestUtils where

14

16

15import Prelude ()

17import Prelude ()

16import Prelude.Compat

18import Prelude.Compat

@@ -18,6 +20,7 @@ import Prelude.Compat

18import Data.Maybe (fromMaybe)

20import Data.Maybe (fromMaybe)

19import Control.Monad

21import Control.Monad

20import Control.Monad.Trans.Maybe

22import Control.Monad.Trans.Maybe

23+import Control.Exception

21

24

22import System.Process

25import System.Process

23import System.Directory

26import System.Directory

@@ -30,8 +33,16 @@ findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names

30 where

33 where

31 names = ["nodejs", "node"]

34 names = ["nodejs", "node"]

32

35

33−fetchSupportCode :: IO ()

36+-- |

34−fetchSupportCode = do

37+-- Fetches code necessary to run the tests with. The resulting support code

38+-- should then be checked in, so that npm/bower etc is not required to run the

39+-- tests.

40+--

41+-- Simply rerun this (via ghci is probably easiest) when the support code needs

42+-- updating.

43+--

44+updateSupportCode :: IO ()

45+updateSupportCode = do

35 node <- fromMaybe (internalError "cannot find node executable") <$> findNodeProcess

46 node <- fromMaybe (internalError "cannot find node executable") <$> findNodeProcess

36 setCurrentDirectory "tests/support"

47 setCurrentDirectory "tests/support"

37 if System.Info.os == "mingw32"

48 if System.Info.os == "mingw32"

@@ -43,3 +54,12 @@ fetchSupportCode = do

43 callProcess "node_modules/.bin/bower" ["--allow-root", "install", "--config.interactive=false"]

54 callProcess "node_modules/.bin/bower" ["--allow-root", "install", "--config.interactive=false"]

44 callProcess node ["setup.js"]

55 callProcess node ["setup.js"]

45 setCurrentDirectory "../.."

56 setCurrentDirectory "../.."

57+

58+pushd :: forall a. FilePath -> IO a -> IO a

59+pushd dir act = do

60+ original <- getCurrentDirectory

61+ setCurrentDirectory dir

62+ result <- try act :: IO (Either IOException a)

63+ setCurrentDirectory original

64+ either throwIO return result

65+

tests/support/flattened/Control-Monad-Eff-Class.pursnew file+24

@@ -0,0 +1,24 @@

1+module Control.Monad.Eff.Class

2+ ( MonadEff

3+ , liftEff

4+ ) where

5+

6+import Prelude

7+

8+import Control.Monad.Eff

9+

10+-- | The `MonadEff` class captures those monads which support native effects.

11+-- |

12+-- | Instances are provided for `Eff` itself, and the standard monad transformers.

13+-- |

14+-- | `liftEff` can be used in any appropriate monad transformer stack to lift an action

15+-- | of type `Eff eff a` into the monad.

16+-- |

17+-- | Note that `MonadEff` is parameterized by the row of effects, so type inference can be

18+-- | tricky. It is generally recommended to either work with a polymorphic row of effects,

19+-- | or a concrete, closed row of effects such as `(trace :: Trace)`.

20+class (Monad m) <= MonadEff eff m where

21+ liftEff :: forall a. Eff eff a -> m a

22+

23+instance monadEffEff :: MonadEff eff (Eff eff) where

24+ liftEff = id

tests/support/flattened/Control-Monad-Eff-Console.jsnew file+18

@@ -0,0 +1,18 @@

1+/* global exports, console */

2+"use strict";

3+

4+// module Control.Monad.Eff.Console

5+

6+exports.log = function (s) {

7+ return function () {

8+ console.log(s);

9+ return {};

10+ };

11+};

12+

13+exports.error = function (s) {

14+ return function () {

15+ console.error(s);

16+ return {};

17+ };

18+};

tests/support/flattened/Control-Monad-Eff-Console.pursnew file+18

@@ -0,0 +1,18 @@

1+module Control.Monad.Eff.Console where

2+

3+import Prelude

4+

5+import Control.Monad.Eff

6+

7+-- | The `CONSOLE` effect represents those computations which write to the console.

8+foreign import data CONSOLE :: !

9+

10+-- | Write a message to the console.

11+foreign import log :: forall eff. String -> Eff (console :: CONSOLE | eff) Unit

12+

13+-- | Write an error to the console.

14+foreign import error :: forall eff. String -> Eff (console :: CONSOLE | eff) Unit

15+

16+-- | Write a value to the console, using its `Show` instance to produce a `String`.

17+print :: forall a eff. (Show a) => a -> Eff (console :: CONSOLE | eff) Unit

18+print = log <<< show

tests/support/flattened/Control-Monad-Eff-Unsafe.jsnew file+8

@@ -0,0 +1,8 @@

1+/* global exports */

2+"use strict";

3+

4+// module Control.Monad.Eff.Unsafe

5+

6+exports.unsafeInterleaveEff = function (f) {

7+ return f;

8+};

tests/support/flattened/Control-Monad-Eff-Unsafe.pursnew file+10

@@ -0,0 +1,10 @@

1+module Control.Monad.Eff.Unsafe where

2+

3+import Prelude

4+

5+import Control.Monad.Eff

6+

7+-- | Change the type of an effectful computation, allowing it to be run in another context.

8+-- |

9+-- | Note: use of this function can result in arbitrary side-effects.

10+foreign import unsafeInterleaveEff :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a

tests/support/flattened/Control-Monad-Eff.jsnew file+62

@@ -0,0 +1,62 @@

1+/* global exports */

2+"use strict";

3+

4+// module Control.Monad.Eff

5+

6+exports.returnE = function (a) {

7+ return function () {

8+ return a;

9+ };

10+};

11+

12+exports.bindE = function (a) {

13+ return function (f) {

14+ return function () {

15+ return f(a())();

16+ };

17+ };

18+};

19+

20+exports.runPure = function (f) {

21+ return f();

22+};

23+

24+exports.untilE = function (f) {

25+ return function () {

26+ while (!f());

27+ return {};

28+ };

29+};

30+

31+exports.whileE = function (f) {

32+ return function (a) {

33+ return function () {

34+ while (f()) {

35+ a();

36+ }

37+ return {};

38+ };

39+ };

40+};

41+

42+exports.forE = function (lo) {

43+ return function (hi) {

44+ return function (f) {

45+ return function () {

46+ for (var i = lo; i < hi; i++) {

47+ f(i)();

48+ }

49+ };

50+ };

51+ };

52+};

53+

54+exports.foreachE = function (as) {

55+ return function (f) {

56+ return function () {

57+ for (var i = 0, l = as.length; i < l; i++) {

58+ f(as[i])();

59+ }

60+ };

61+ };

62+};

tests/support/flattened/Control-Monad-Eff.pursnew file+67

@@ -0,0 +1,67 @@

1+module Control.Monad.Eff

2+ ( Eff()

3+ , Pure()

4+ , runPure

5+ , untilE, whileE, forE, foreachE

6+ ) where

7+

8+import Prelude

9+

10+-- | The `Eff` type constructor is used to represent _native_ effects.

11+-- |

12+-- | See [Handling Native Effects with the Eff Monad](https://github.com/purescript/purescript/wiki/Handling-Native-Effects-with-the-Eff-Monad) for more details.

13+-- |

14+-- | The first type parameter is a row of effects which represents the contexts in which a computation can be run, and the second type parameter is the return type.

15+foreign import data Eff :: # ! -> * -> *

16+

17+foreign import returnE :: forall e a. a -> Eff e a

18+

19+foreign import bindE :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

20+

21+-- | The `Pure` type synonym represents _pure_ computations, i.e. ones in which all effects have been handled.

22+-- |

23+-- | The `runPure` function can be used to run pure computations and obtain their result.

24+type Pure a = forall e. Eff e a

25+

26+-- | Run a pure computation and return its result.

27+-- |

28+-- | Note: since this function has a rank-2 type, it may cause problems to apply this function using the `$` operator. The recommended approach

29+-- | is to use parentheses instead.

30+foreign import runPure :: forall a. Pure a -> a

31+

32+instance functorEff :: Functor (Eff e) where

33+ map = liftA1

34+

35+instance applyEff :: Apply (Eff e) where

36+ apply = ap

37+

38+instance applicativeEff :: Applicative (Eff e) where

39+ pure = returnE

40+

41+instance bindEff :: Bind (Eff e) where

42+ bind = bindE

43+

44+instance monadEff :: Monad (Eff e)

45+

46+-- | Loop until a condition becomes `true`.

47+-- |

48+-- | `untilE b` is an effectful computation which repeatedly runs the effectful computation `b`,

49+-- | until its return value is `true`.

50+foreign import untilE :: forall e. Eff e Boolean -> Eff e Unit

51+

52+-- | Loop while a condition is `true`.

53+-- |

54+-- | `whileE b m` is effectful computation which runs the effectful computation `b`. If its result is

55+-- | `true`, it runs the effectful computation `m` and loops. If not, the computation ends.

56+foreign import whileE :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit

57+

58+-- | Loop over a consecutive collection of numbers.

59+-- |

60+-- | `forE lo hi f` runs the computation returned by the function `f` for each of the inputs

61+-- | between `lo` (inclusive) and `hi` (exclusive).

62+foreign import forE :: forall e. Number -> Number -> (Number -> Eff e Unit) -> Eff e Unit

63+

64+-- | Loop over an array of values.

65+-- |

66+-- | `foreach xs f` runs the computation returned by the function `f` for each of the inputs `xs`.

67+foreign import foreachE :: forall e a. Array a -> (a -> Eff e Unit) -> Eff e Unit

tests/support/flattened/Control-Monad-ST.jsnew file+38

@@ -0,0 +1,38 @@

1+/* global exports */

2+"use strict";

3+

4+// module Control.Monad.ST

5+

6+exports.newSTRef = function (val) {

7+ return function () {

8+ return { value: val };

9+ };

10+};

11+

12+exports.readSTRef = function (ref) {

13+ return function () {

14+ return ref.value;

15+ };

16+};

17+

18+exports.modifySTRef = function (ref) {

19+ return function (f) {

20+ return function () {

21+ /* jshint boss: true */

22+ return ref.value = f(ref.value);

23+ };

24+ };

25+};

26+

27+exports.writeSTRef = function (ref) {

28+ return function (a) {

29+ return function () {

30+ /* jshint boss: true */

31+ return ref.value = a;

32+ };

33+ };

34+};

35+

36+exports.runST = function (f) {

37+ return f;

38+};

tests/support/flattened/Control-Monad-ST.pursnew file+42

@@ -0,0 +1,42 @@

1+module Control.Monad.ST where

2+

3+import Prelude

4+

5+import Control.Monad.Eff (Eff(), runPure)

6+

7+-- | The `ST` effect represents _local mutation_, i.e. mutation which does not "escape" into the surrounding computation.

8+-- |

9+-- | An `ST` computation is parameterized by a phantom type which is used to restrict the set of reference cells it is allowed to access.

10+-- |

11+-- | The `runST` function can be used to handle the `ST` effect.

12+foreign import data ST :: * -> !

13+

14+-- | The type `STRef s a` represents a mutable reference holding a value of type `a`, which can be used with the `ST s` effect.

15+foreign import data STRef :: * -> * -> *

16+

17+-- | Create a new mutable reference.

18+foreign import newSTRef :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)

19+

20+-- | Read the current value of a mutable reference.

21+foreign import readSTRef :: forall a h r. STRef h a -> Eff (st :: ST h | r) a

22+

23+-- | Modify the value of a mutable reference by applying a function to the current value.

24+foreign import modifySTRef :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a

25+

26+-- | Set the value of a mutable reference.

27+foreign import writeSTRef :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a

28+

29+-- | Run an `ST` computation.

30+-- |

31+-- | Note: the type of `runST` uses a rank-2 type to constrain the phantom type `s`, such that the computation must not leak any mutable references

32+-- | to the surrounding computation.

33+-- |

34+-- | It may cause problems to apply this function using the `$` operator. The recommended approach is to use parentheses instead.

35+foreign import runST :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a

36+

37+-- | A convenience function which combines `runST` with `runPure`, which can be used when the only required effect is `ST`.

38+-- |

39+-- | Note: since this function has a rank-2 type, it may cause problems to apply this function using the `$` operator. The recommended approach

40+-- | is to use parentheses instead.

41+pureST :: forall a. (forall h r. Eff (st :: ST h | r) a) -> a

42+pureST st = runPure (runST st)

tests/support/flattened/Data-Function.jsnew file+233

@@ -0,0 +1,233 @@

1+/* global exports */

2+"use strict";

3+

4+// module Data.Function

5+

6+exports.mkFn0 = function (fn) {

7+ return function () {

8+ return fn({});

9+ };

10+};

11+

12+exports.mkFn1 = function (fn) {

13+ return function (a) {

14+ return fn(a);

15+ };

16+};

17+

18+exports.mkFn2 = function (fn) {

19+ /* jshint maxparams: 2 */

20+ return function (a, b) {

21+ return fn(a)(b);

22+ };

23+};

24+

25+exports.mkFn3 = function (fn) {

26+ /* jshint maxparams: 3 */

27+ return function (a, b, c) {

28+ return fn(a)(b)(c);

29+ };

30+};

31+

32+exports.mkFn4 = function (fn) {

33+ /* jshint maxparams: 4 */

34+ return function (a, b, c, d) {

35+ return fn(a)(b)(c)(d);

36+ };

37+};

38+

39+exports.mkFn5 = function (fn) {

40+ /* jshint maxparams: 5 */

41+ return function (a, b, c, d, e) {

42+ return fn(a)(b)(c)(d)(e);

43+ };

44+};

45+

46+exports.mkFn6 = function (fn) {

47+ /* jshint maxparams: 6 */

48+ return function (a, b, c, d, e, f) {

49+ return fn(a)(b)(c)(d)(e)(f);

50+ };

51+};

52+

53+exports.mkFn7 = function (fn) {

54+ /* jshint maxparams: 7 */

55+ return function (a, b, c, d, e, f, g) {

56+ return fn(a)(b)(c)(d)(e)(f)(g);

57+ };

58+};

59+

60+exports.mkFn8 = function (fn) {

61+ /* jshint maxparams: 8 */

62+ return function (a, b, c, d, e, f, g, h) {

63+ return fn(a)(b)(c)(d)(e)(f)(g)(h);

64+ };

65+};

66+

67+exports.mkFn9 = function (fn) {

68+ /* jshint maxparams: 9 */

69+ return function (a, b, c, d, e, f, g, h, i) {

70+ return fn(a)(b)(c)(d)(e)(f)(g)(h)(i);

71+ };

72+};

73+

74+exports.mkFn10 = function (fn) {

75+ /* jshint maxparams: 10 */

76+ return function (a, b, c, d, e, f, g, h, i, j) {

77+ return fn(a)(b)(c)(d)(e)(f)(g)(h)(i)(j);

78+ };

79+};

80+

81+exports.runFn0 = function (fn) {

82+ return fn();

83+};

84+

85+exports.runFn1 = function (fn) {

86+ return function (a) {

87+ return fn(a);

88+ };

89+};

90+

91+exports.runFn2 = function (fn) {

92+ return function (a) {

93+ return function (b) {

94+ return fn(a, b);

95+ };

96+ };

97+};

98+

99+exports.runFn3 = function (fn) {

100+ return function (a) {

101+ return function (b) {

102+ return function (c) {

103+ return fn(a, b, c);

104+ };

105+ };

106+ };

107+};

108+

109+exports.runFn4 = function (fn) {

110+ return function (a) {

111+ return function (b) {

112+ return function (c) {

113+ return function (d) {

114+ return fn(a, b, c, d);

115+ };

116+ };

117+ };

118+ };

119+};

120+

121+exports.runFn5 = function (fn) {

122+ return function (a) {

123+ return function (b) {

124+ return function (c) {

125+ return function (d) {

126+ return function (e) {

127+ return fn(a, b, c, d, e);

128+ };

129+ };

130+ };

131+ };

132+ };

133+};

134+

135+exports.runFn6 = function (fn) {

136+ return function (a) {

137+ return function (b) {

138+ return function (c) {

139+ return function (d) {

140+ return function (e) {

141+ return function (f) {

142+ return fn(a, b, c, d, e, f);

143+ };

144+ };

145+ };

146+ };

147+ };

148+ };

149+};

150+

151+exports.runFn7 = function (fn) {

152+ return function (a) {

153+ return function (b) {

154+ return function (c) {

155+ return function (d) {

156+ return function (e) {

157+ return function (f) {

158+ return function (g) {

159+ return fn(a, b, c, d, e, f, g);

160+ };

161+ };

162+ };

163+ };

164+ };

165+ };

166+ };

167+};

168+

169+exports.runFn8 = function (fn) {

170+ return function (a) {

171+ return function (b) {

172+ return function (c) {

173+ return function (d) {

174+ return function (e) {

175+ return function (f) {

176+ return function (g) {

177+ return function (h) {

178+ return fn(a, b, c, d, e, f, g, h);

179+ };

180+ };

181+ };

182+ };

183+ };

184+ };

185+ };

186+ };

187+};

188+

189+exports.runFn9 = function (fn) {

190+ return function (a) {

191+ return function (b) {

192+ return function (c) {

193+ return function (d) {

194+ return function (e) {

195+ return function (f) {

196+ return function (g) {

197+ return function (h) {

198+ return function (i) {

199+ return fn(a, b, c, d, e, f, g, h, i);

200+ };

201+ };

202+ };

203+ };

204+ };

205+ };

206+ };

207+ };

208+ };

209+};

210+

211+exports.runFn10 = function (fn) {

212+ return function (a) {

213+ return function (b) {

214+ return function (c) {

215+ return function (d) {

216+ return function (e) {

217+ return function (f) {

218+ return function (g) {

219+ return function (h) {

220+ return function (i) {

221+ return function (j) {

222+ return fn(a, b, c, d, e, f, g, h, i, j);

223+ };

224+ };

225+ };

226+ };

227+ };

228+ };

229+ };

230+ };

231+ };

232+ };

233+};

tests/support/flattened/Data-Function.pursnew file+113

@@ -0,0 +1,113 @@

1+module Data.Function where

2+

3+import Prelude

4+

5+-- | The `on` function is used to change the domain of a binary operator.

6+-- |

7+-- | For example, we can create a function which compares two records based on the values of their `x` properties:

8+-- |

9+-- | ```purescript

10+-- | compareX :: forall r. { x :: Number | r } -> { x :: Number | r } -> Ordering

11+-- | compareX = compare `on` _.x

12+-- | ```

13+on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c

14+on f g x y = g x `f` g y

15+

16+-- | A function of zero arguments

17+foreign import data Fn0 :: * -> *

18+

19+-- | A function of one argument

20+foreign import data Fn1 :: * -> * -> *

21+

22+-- | A function of two arguments

23+foreign import data Fn2 :: * -> * -> * -> *

24+

25+-- | A function of three arguments

26+foreign import data Fn3 :: * -> * -> * -> * -> *

27+

28+-- | A function of four arguments

29+foreign import data Fn4 :: * -> * -> * -> * -> * -> *

30+

31+-- | A function of five arguments

32+foreign import data Fn5 :: * -> * -> * -> * -> * -> * -> *

33+

34+-- | A function of six arguments

35+foreign import data Fn6 :: * -> * -> * -> * -> * -> * -> * -> *

36+

37+-- | A function of seven arguments

38+foreign import data Fn7 :: * -> * -> * -> * -> * -> * -> * -> * -> *

39+

40+-- | A function of eight arguments

41+foreign import data Fn8 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> *

42+

43+-- | A function of nine arguments

44+foreign import data Fn9 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *

45+

46+-- | A function of ten arguments

47+foreign import data Fn10 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *

48+

49+-- | Create a function of no arguments

50+foreign import mkFn0 :: forall a. (Unit -> a) -> Fn0 a

51+

52+-- | Create a function of one argument

53+foreign import mkFn1 :: forall a b. (a -> b) -> Fn1 a b

54+

55+-- | Create a function of two arguments from a curried function

56+foreign import mkFn2 :: forall a b c. (a -> b -> c) -> Fn2 a b c

57+

58+-- | Create a function of three arguments from a curried function

59+foreign import mkFn3 :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d

60+

61+-- | Create a function of four arguments from a curried function

62+foreign import mkFn4 :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e

63+

64+-- | Create a function of five arguments from a curried function

65+foreign import mkFn5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f

66+

67+-- | Create a function of six arguments from a curried function

68+foreign import mkFn6 :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> Fn6 a b c d e f g

69+

70+-- | Create a function of seven arguments from a curried function

71+foreign import mkFn7 :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> Fn7 a b c d e f g h

72+

73+-- | Create a function of eight arguments from a curried function

74+foreign import mkFn8 :: forall a b c d e f g h i. (a -> b -> c -> d -> e -> f -> g -> h -> i) -> Fn8 a b c d e f g h i

75+

76+-- | Create a function of nine arguments from a curried function

77+foreign import mkFn9 :: forall a b c d e f g h i j. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> Fn9 a b c d e f g h i j

78+

79+-- | Create a function of ten arguments from a curried function

80+foreign import mkFn10 :: forall a b c d e f g h i j k. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) -> Fn10 a b c d e f g h i j k

81+

82+-- | Apply a function of no arguments

83+foreign import runFn0 :: forall a. Fn0 a -> a

84+

85+-- | Apply a function of one argument

86+foreign import runFn1 :: forall a b. Fn1 a b -> a -> b

87+

88+-- | Apply a function of two arguments

89+foreign import runFn2 :: forall a b c. Fn2 a b c -> a -> b -> c

90+

91+-- | Apply a function of three arguments

92+foreign import runFn3 :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d

93+

94+-- | Apply a function of four arguments

95+foreign import runFn4 :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e

96+

97+-- | Apply a function of five arguments

98+foreign import runFn5 :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f

99+

100+-- | Apply a function of six arguments

101+foreign import runFn6 :: forall a b c d e f g. Fn6 a b c d e f g -> a -> b -> c -> d -> e -> f -> g

102+

103+-- | Apply a function of seven arguments

104+foreign import runFn7 :: forall a b c d e f g h. Fn7 a b c d e f g h -> a -> b -> c -> d -> e -> f -> g -> h

105+

106+-- | Apply a function of eight arguments

107+foreign import runFn8 :: forall a b c d e f g h i. Fn8 a b c d e f g h i -> a -> b -> c -> d -> e -> f -> g -> h -> i

108+

109+-- | Apply a function of nine arguments

110+foreign import runFn9 :: forall a b c d e f g h i j. Fn9 a b c d e f g h i j -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j

111+

112+-- | Apply a function of ten arguments

113+foreign import runFn10 :: forall a b c d e f g h i j k. Fn10 a b c d e f g h i j k -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k

tests/support/flattened/Prelude.jsnew file+228

@@ -0,0 +1,228 @@

1+/* global exports */

2+"use strict";

3+

4+// module Prelude

5+

6+//- Functor --------------------------------------------------------------------

7+

8+exports.arrayMap = function (f) {

9+ return function (arr) {

10+ var l = arr.length;

11+ var result = new Array(l);

12+ for (var i = 0; i < l; i++) {

13+ result[i] = f(arr[i]);

14+ }

15+ return result;

16+ };

17+};

18+

19+//- Bind -----------------------------------------------------------------------

20+

21+exports.arrayBind = function (arr) {

22+ return function (f) {

23+ var result = [];

24+ for (var i = 0, l = arr.length; i < l; i++) {

25+ Array.prototype.push.apply(result, f(arr[i]));

26+ }

27+ return result;

28+ };

29+};

30+

31+//- Monoid ---------------------------------------------------------------------

32+

33+exports.concatString = function (s1) {

34+ return function (s2) {

35+ return s1 + s2;

36+ };

37+};

38+

39+exports.concatArray = function (xs) {

40+ return function (ys) {

41+ return xs.concat(ys);

42+ };

43+};

44+

45+//- Semiring -------------------------------------------------------------------

46+

47+exports.intAdd = function (x) {

48+ return function (y) {

49+ /* jshint bitwise: false */

50+ return x + y | 0;

51+ };

52+};

53+

54+exports.intMul = function (x) {

55+ return function (y) {

56+ /* jshint bitwise: false */

57+ return x * y | 0;

58+ };

59+};

60+

61+exports.numAdd = function (n1) {

62+ return function (n2) {

63+ return n1 + n2;

64+ };

65+};

66+

67+exports.numMul = function (n1) {

68+ return function (n2) {

69+ return n1 * n2;

70+ };

71+};

72+

73+//- ModuloSemiring -------------------------------------------------------------

74+

75+exports.intDiv = function (x) {

76+ return function (y) {

77+ /* jshint bitwise: false */

78+ return x / y | 0;

79+ };

80+};

81+

82+exports.intMod = function (x) {

83+ return function (y) {

84+ return x % y;

85+ };

86+};

87+

88+exports.numDiv = function (n1) {

89+ return function (n2) {

90+ return n1 / n2;

91+ };

92+};

93+

94+//- Ring -----------------------------------------------------------------------

95+

96+exports.intSub = function (x) {

97+ return function (y) {

98+ /* jshint bitwise: false */

99+ return x - y | 0;

100+ };

101+};

102+

103+exports.numSub = function (n1) {

104+ return function (n2) {

105+ return n1 - n2;

106+ };

107+};

108+

109+//- Eq -------------------------------------------------------------------------

110+

111+exports.refEq = function (r1) {

112+ return function (r2) {

113+ return r1 === r2;

114+ };

115+};

116+

117+exports.refIneq = function (r1) {

118+ return function (r2) {

119+ return r1 !== r2;

120+ };

121+};

122+

123+exports.eqArrayImpl = function (f) {

124+ return function (xs) {

125+ return function (ys) {

126+ if (xs.length !== ys.length) return false;

127+ for (var i = 0; i < xs.length; i++) {

128+ if (!f(xs[i])(ys[i])) return false;

129+ }

130+ return true;

131+ };

132+ };

133+};

134+

135+exports.ordArrayImpl = function (f) {

136+ return function (xs) {

137+ return function (ys) {

138+ var i = 0;

139+ var xlen = xs.length;

140+ var ylen = ys.length;

141+ while (i < xlen && i < ylen) {

142+ var x = xs[i];

143+ var y = ys[i];

144+ var o = f(x)(y);

145+ if (o !== 0) {

146+ return o;

147+ }

148+ i++;

149+ }

150+ if (xlen === ylen) {

151+ return 0;

152+ } else if (xlen > ylen) {

153+ return -1;

154+ } else {

155+ return 1;

156+ }

157+ };

158+ };

159+};

160+

161+//- Ord ------------------------------------------------------------------------

162+

163+exports.unsafeCompareImpl = function (lt) {

164+ return function (eq) {

165+ return function (gt) {

166+ return function (x) {

167+ return function (y) {

168+ return x < y ? lt : x > y ? gt : eq;

169+ };

170+ };

171+ };

172+ };

173+};

174+

175+//- Bounded --------------------------------------------------------------------

176+

177+exports.topInt = 2147483647;

178+exports.bottomInt = -2147483648;

179+

180+exports.topChar = String.fromCharCode(65535);

181+exports.bottomChar = String.fromCharCode(0);

182+

183+//- BooleanAlgebra -------------------------------------------------------------

184+

185+exports.boolOr = function (b1) {

186+ return function (b2) {

187+ return b1 || b2;

188+ };

189+};

190+

191+exports.boolAnd = function (b1) {

192+ return function (b2) {

193+ return b1 && b2;

194+ };

195+};

196+

197+exports.boolNot = function (b) {

198+ return !b;

199+};

200+

201+//- Show -----------------------------------------------------------------------

202+

203+exports.showIntImpl = function (n) {

204+ return n.toString();

205+};

206+

207+exports.showNumberImpl = function (n) {

208+ /* jshint bitwise: false */

209+ return n === (n | 0) ? n + ".0" : n.toString();

210+};

211+

212+exports.showCharImpl = function (c) {

213+ return c === "'" ? "'\\''" : "'" + c + "'";

214+};

215+

216+exports.showStringImpl = function (s) {

217+ return JSON.stringify(s);

218+};

219+

220+exports.showArrayImpl = function (f) {

221+ return function (xs) {

222+ var ss = [];

223+ for (var i = 0, l = xs.length; i < l; i++) {

224+ ss[i] = f(xs[i]);

225+ }

226+ return "[" + ss.join(",") + "]";

227+ };

228+};

tests/support/flattened/Prelude.pursnew file+872

@@ -0,0 +1,872 @@

1+module Prelude

2+ ( Unit(), unit

3+ , ($), (#)

4+ , flip

5+ , const

6+ , asTypeOf

7+ , otherwise

8+ , Semigroupoid, compose, (<<<), (>>>)

9+ , Category, id

10+ , Functor, map, (<$>), (<#>), void

11+ , Apply, apply, (<*>)

12+ , Applicative, pure, liftA1

13+ , Bind, bind, (>>=)

14+ , Monad, return, liftM1, ap

15+ , Semigroup, append, (<>), (++)

16+ , Semiring, add, zero, mul, one, (+), (*)

17+ , ModuloSemiring, div, mod, (/)

18+ , Ring, sub, negate, (-)

19+ , Num

20+ , DivisionRing

21+ , Eq, eq, (==), (/=)

22+ , Ordering(..), Ord, compare, (<), (>), (<=), (>=)

23+ , unsafeCompare

24+ , Bounded, top, bottom

25+ , BoundedOrd

26+ , BooleanAlgebra, conj, disj, not, (&&), (||)

27+ , Show, show

28+ ) where

29+

30+-- | The `Unit` type has a single inhabitant, called `unit`. It represents

31+-- | values with no computational content.

32+-- |

33+-- | `Unit` is often used, wrapped in a monadic type constructor, as the

34+-- | return type of a computation where only

35+-- | the _effects_ are important.

36+newtype Unit = Unit {}

37+

38+-- | `unit` is the sole inhabitant of the `Unit` type.

39+unit :: Unit

40+unit = Unit {}

41+

42+infixr 0 $

43+infixl 1 #

44+

45+-- | Applies a function to its argument.

46+-- |

47+-- | ```purescript

48+-- | length $ groupBy productCategory $ filter isInStock $ products

49+-- | ```

50+-- |

51+-- | is equivalent to:

52+-- |

53+-- | ```purescript

54+-- | length (groupBy productCategory (filter isInStock products))

55+-- | ```

56+-- |

57+-- | `($)` is different from [`(#)`](#-2) because it is right-infix instead of

58+-- | left: `a $ b $ c $ d x = a $ (b $ (c $ (d $ x))) = a (b (c (d x)))`

59+($) :: forall a b. (a -> b) -> a -> b

60+($) f x = f x

61+

62+-- | Applies an argument to a function.

63+-- |

64+-- | ```purescript

65+-- | products # filter isInStock # groupBy productCategory # length

66+-- | ```

67+-- |

68+-- | is equivalent to:

69+-- |

70+-- | ```purescript

71+-- | length (groupBy productCategory (filter isInStock products))

72+-- | ```

73+-- |

74+-- | `(#)` is different from [`($)`](#-1) because it is left-infix instead of

75+-- | right: `x # a # b # c # d = (((x # a) # b) # c) # d = d (c (b (a x)))`

76+(#) :: forall a b. a -> (a -> b) -> b

77+(#) x f = f x

78+

79+-- | Flips the order of the arguments to a function of two arguments.

80+-- |

81+-- | ```purescript

82+-- | flip const 1 2 = const 2 1 = 2

83+-- | ```

84+flip :: forall a b c. (a -> b -> c) -> b -> a -> c

85+flip f b a = f a b

86+

87+-- | Returns its first argument and ignores its second.

88+-- |

89+-- | ```purescript

90+-- | const 1 "hello" = 1

91+-- | ```

92+const :: forall a b. a -> b -> a

93+const a _ = a

94+

95+-- | This function returns its first argument, and can be used to assert type

96+-- | equalities. This can be useful when types are otherwise ambiguous.

97+-- |

98+-- | ```purescript

99+-- | main = print $ [] `asTypeOf` [0]

100+-- | ```

101+-- |

102+-- | If instead, we had written `main = print []`, the type of the argument

103+-- | `[]` would have been ambiguous, resulting in a compile-time error.

104+asTypeOf :: forall a. a -> a -> a

105+asTypeOf x _ = x

106+

107+-- | An alias for `true`, which can be useful in guard clauses:

108+-- |

109+-- | ```purescript

110+-- | max x y | x >= y = x

111+-- | | otherwise = y

112+-- | ```

113+otherwise :: Boolean

114+otherwise = true

115+

116+-- | A `Semigroupoid` is similar to a [`Category`](#category) but does not

117+-- | require an identity element `id`, just composable morphisms.

118+-- |

119+-- | `Semigroupoid`s must satisfy the following law:

120+-- |

121+-- | - Associativity: `p <<< (q <<< r) = (p <<< q) <<< r`

122+-- |

123+-- | One example of a `Semigroupoid` is the function type constructor `(->)`,

124+-- | with `(<<<)` defined as function composition.

125+class Semigroupoid a where

126+ compose :: forall b c d. a c d -> a b c -> a b d

127+

128+instance semigroupoidFn :: Semigroupoid (->) where

129+ compose f g x = f (g x)

130+

131+infixr 9 >>>

132+infixr 9 <<<

133+

134+-- | `(<<<)` is an alias for `compose`.

135+(<<<) :: forall a b c d. (Semigroupoid a) => a c d -> a b c -> a b d

136+(<<<) = compose

137+

138+-- | Forwards composition, or `(<<<)` with its arguments reversed.

139+(>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d

140+(>>>) = flip compose

141+

142+-- | `Category`s consist of objects and composable morphisms between them, and

143+-- | as such are [`Semigroupoids`](#semigroupoid), but unlike `semigroupoids`

144+-- | must have an identity element.

145+-- |

146+-- | Instances must satisfy the following law in addition to the

147+-- | `Semigroupoid` law:

148+-- |

149+-- | - Identity: `id <<< p = p <<< id = p`

150+class (Semigroupoid a) <= Category a where

151+ id :: forall t. a t t

152+

153+instance categoryFn :: Category (->) where

154+ id x = x

155+

156+-- | A `Functor` is a type constructor which supports a mapping operation

157+-- | `(<$>)`.

158+-- |

159+-- | `(<$>)` can be used to turn functions `a -> b` into functions

160+-- | `f a -> f b` whose argument and return types use the type constructor `f`

161+-- | to represent some computational context.

162+-- |

163+-- | Instances must satisfy the following laws:

164+-- |

165+-- | - Identity: `(<$>) id = id`

166+-- | - Composition: `(<$>) (f <<< g) = (f <$>) <<< (g <$>)`

167+class Functor f where

168+ map :: forall a b. (a -> b) -> f a -> f b

169+

170+instance functorFn :: Functor ((->) r) where

171+ map = compose

172+

173+instance functorArray :: Functor Array where

174+ map = arrayMap

175+

176+foreign import arrayMap :: forall a b. (a -> b) -> Array a -> Array b

177+

178+infixl 4 <$>

179+infixl 1 <#>

180+

181+-- | `(<$>)` is an alias for `map`

182+(<$>) :: forall f a b. (Functor f) => (a -> b) -> f a -> f b

183+(<$>) = map

184+

185+-- | `(<#>)` is `(<$>)` with its arguments reversed. For example:

186+-- |

187+-- | ```purescript

188+-- | [1, 2, 3] <#> \n -> n * n

189+-- | ```

190+(<#>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b

191+(<#>) fa f = f <$> fa

192+

193+-- | The `void` function is used to ignore the type wrapped by a

194+-- | [`Functor`](#functor), replacing it with `Unit` and keeping only the type

195+-- | information provided by the type constructor itself.

196+-- |

197+-- | `void` is often useful when using `do` notation to change the return type

198+-- | of a monadic computation:

199+-- |

200+-- | ```purescript

201+-- | main = forE 1 10 \n -> void do

202+-- | print n

203+-- | print (n * n)

204+-- | ```

205+void :: forall f a. (Functor f) => f a -> f Unit

206+void fa = const unit <$> fa

207+

208+-- | The `Apply` class provides the `(<*>)` which is used to apply a function

209+-- | to an argument under a type constructor.

210+-- |

211+-- | `Apply` can be used to lift functions of two or more arguments to work on

212+-- | values wrapped with the type constructor `f`. It might also be understood

213+-- | in terms of the `lift2` function:

214+-- |

215+-- | ```purescript

216+-- | lift2 :: forall f a b c. (Apply f) => (a -> b -> c) -> f a -> f b -> f c

217+-- | lift2 f a b = f <$> a <*> b

218+-- | ```

219+-- |

220+-- | `(<*>)` is recovered from `lift2` as `lift2 ($)`. That is, `(<*>)` lifts

221+-- | the function application operator `($)` to arguments wrapped with the

222+-- | type constructor `f`.

223+-- |

224+-- | Instances must satisfy the following law in addition to the `Functor`

225+-- | laws:

226+-- |

227+-- | - Associative composition: `(<<<) <$> f <*> g <*> h = f <*> (g <*> h)`

228+-- |

229+-- | Formally, `Apply` represents a strong lax semi-monoidal endofunctor.

230+class (Functor f) <= Apply f where

231+ apply :: forall a b. f (a -> b) -> f a -> f b

232+

233+instance applyFn :: Apply ((->) r) where

234+ apply f g x = f x (g x)

235+

236+instance applyArray :: Apply Array where

237+ apply = ap

238+

239+infixl 4 <*>

240+

241+-- | `(<*>)` is an alias for `apply`.

242+(<*>) :: forall f a b. (Apply f) => f (a -> b) -> f a -> f b

243+(<*>) = apply

244+

245+-- | The `Applicative` type class extends the [`Apply`](#apply) type class

246+-- | with a `pure` function, which can be used to create values of type `f a`

247+-- | from values of type `a`.

248+-- |

249+-- | Where [`Apply`](#apply) provides the ability to lift functions of two or

250+-- | more arguments to functions whose arguments are wrapped using `f`, and

251+-- | [`Functor`](#functor) provides the ability to lift functions of one

252+-- | argument, `pure` can be seen as the function which lifts functions of

253+-- | _zero_ arguments. That is, `Applicative` functors support a lifting

254+-- | operation for any number of function arguments.

255+-- |

256+-- | Instances must satisfy the following laws in addition to the `Apply`

257+-- | laws:

258+-- |

259+-- | - Identity: `(pure id) <*> v = v`

260+-- | - Composition: `(pure <<<) <*> f <*> g <*> h = f <*> (g <*> h)`

261+-- | - Homomorphism: `(pure f) <*> (pure x) = pure (f x)`

262+-- | - Interchange: `u <*> (pure y) = (pure ($ y)) <*> u`

263+class (Apply f) <= Applicative f where

264+ pure :: forall a. a -> f a

265+

266+instance applicativeFn :: Applicative ((->) r) where

267+ pure = const

268+

269+instance applicativeArray :: Applicative Array where

270+ pure x = [x]

271+

272+-- | `return` is an alias for `pure`.

273+return :: forall m a. (Applicative m) => a -> m a

274+return = pure

275+

276+-- | `liftA1` provides a default implementation of `(<$>)` for any

277+-- | [`Applicative`](#applicative) functor, without using `(<$>)` as provided

278+-- | by the [`Functor`](#functor)-[`Applicative`](#applicative) superclass

279+-- | relationship.

280+-- |

281+-- | `liftA1` can therefore be used to write [`Functor`](#functor) instances

282+-- | as follows:

283+-- |

284+-- | ```purescript

285+-- | instance functorF :: Functor F where

286+-- | map = liftA1

287+-- | ```

288+liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b

289+liftA1 f a = pure f <*> a

290+

291+-- | The `Bind` type class extends the [`Apply`](#apply) type class with a

292+-- | "bind" operation `(>>=)` which composes computations in sequence, using

293+-- | the return value of one computation to determine the next computation.

294+-- |

295+-- | The `>>=` operator can also be expressed using `do` notation, as follows:

296+-- |

297+-- | ```purescript

298+-- | x >>= f = do y <- x

299+-- | f y

300+-- | ```

301+-- |

302+-- | where the function argument of `f` is given the name `y`.

303+-- |

304+-- | Instances must satisfy the following law in addition to the `Apply`

305+-- | laws:

306+-- |

307+-- | - Associativity: `(x >>= f) >>= g = x >>= (\k => f k >>= g)`

308+-- |

309+-- | Associativity tells us that we can regroup operations which use `do`

310+-- | notation so that we can unambiguously write, for example:

311+-- |

312+-- | ```purescript

313+-- | do x <- m1

314+-- | y <- m2 x

315+-- | m3 x y

316+-- | ```

317+class (Apply m) <= Bind m where

318+ bind :: forall a b. m a -> (a -> m b) -> m b

319+

320+instance bindFn :: Bind ((->) r) where

321+ bind m f x = f (m x) x

322+

323+instance bindArray :: Bind Array where

324+ bind = arrayBind

325+

326+foreign import arrayBind :: forall a b. Array a -> (a -> Array b) -> Array b

327+

328+infixl 1 >>=

329+

330+-- | `(>>=)` is an alias for `bind`.

331+(>>=) :: forall m a b. (Bind m) => m a -> (a -> m b) -> m b

332+(>>=) = bind

333+

334+-- | The `Monad` type class combines the operations of the `Bind` and

335+-- | `Applicative` type classes. Therefore, `Monad` instances represent type

336+-- | constructors which support sequential composition, and also lifting of

337+-- | functions of arbitrary arity.

338+-- |

339+-- | Instances must satisfy the following laws in addition to the

340+-- | `Applicative` and `Bind` laws:

341+-- |

342+-- | - Left Identity: `pure x >>= f = f x`

343+-- | - Right Identity: `x >>= pure = x`

344+class (Applicative m, Bind m) <= Monad m

345+

346+instance monadFn :: Monad ((->) r)

347+instance monadArray :: Monad Array

348+

349+-- | `liftM1` provides a default implementation of `(<$>)` for any

350+-- | [`Monad`](#monad), without using `(<$>)` as provided by the

351+-- | [`Functor`](#functor)-[`Monad`](#monad) superclass relationship.

352+-- |

353+-- | `liftM1` can therefore be used to write [`Functor`](#functor) instances

354+-- | as follows:

355+-- |

356+-- | ```purescript

357+-- | instance functorF :: Functor F where

358+-- | map = liftM1

359+-- | ```

360+liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b

361+liftM1 f a = do

362+ a' <- a

363+ return (f a')

364+

365+-- | `ap` provides a default implementation of `(<*>)` for any

366+-- | [`Monad`](#monad), without using `(<*>)` as provided by the

367+-- | [`Apply`](#apply)-[`Monad`](#monad) superclass relationship.

368+-- |

369+-- | `ap` can therefore be used to write [`Apply`](#apply) instances as

370+-- | follows:

371+-- |

372+-- | ```purescript

373+-- | instance applyF :: Apply F where

374+-- | apply = ap

375+-- | ```

376+ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b

377+ap f a = do

378+ f' <- f

379+ a' <- a

380+ return (f' a')

381+

382+-- | The `Semigroup` type class identifies an associative operation on a type.

383+-- |

384+-- | Instances are required to satisfy the following law:

385+-- |

386+-- | - Associativity: `(x <> y) <> z = x <> (y <> z)`

387+-- |

388+-- | One example of a `Semigroup` is `String`, with `(<>)` defined as string

389+-- | concatenation.

390+class Semigroup a where

391+ append :: a -> a -> a

392+

393+infixr 5 <>

394+infixr 5 ++

395+

396+-- | `(<>)` is an alias for `append`.

397+(<>) :: forall s. (Semigroup s) => s -> s -> s

398+(<>) = append

399+

400+-- | `(++)` is an alternative alias for `append`.

401+(++) :: forall s. (Semigroup s) => s -> s -> s

402+(++) = append

403+

404+instance semigroupString :: Semigroup String where

405+ append = concatString

406+

407+instance semigroupUnit :: Semigroup Unit where

408+ append _ _ = unit

409+

410+instance semigroupFn :: (Semigroup s') => Semigroup (s -> s') where

411+ append f g = \x -> f x <> g x

412+

413+instance semigroupOrdering :: Semigroup Ordering where

414+ append LT _ = LT

415+ append GT _ = GT

416+ append EQ y = y

417+

418+instance semigroupArray :: Semigroup (Array a) where

419+ append = concatArray

420+

421+foreign import concatString :: String -> String -> String

422+foreign import concatArray :: forall a. Array a -> Array a -> Array a

423+

424+-- | The `Semiring` class is for types that support an addition and

425+-- | multiplication operation.

426+-- |

427+-- | Instances must satisfy the following laws:

428+-- |

429+-- | - Commutative monoid under addition:

430+-- | - Associativity: `(a + b) + c = a + (b + c)`

431+-- | - Identity: `zero + a = a + zero = a`

432+-- | - Commutative: `a + b = b + a`

433+-- | - Monoid under multiplication:

434+-- | - Associativity: `(a * b) * c = a * (b * c)`

435+-- | - Identity: `one * a = a * one = a`

436+-- | - Multiplication distributes over addition:

437+-- | - Left distributivity: `a * (b + c) = (a * b) + (a * c)`

438+-- | - Right distributivity: `(a + b) * c = (a * c) + (b * c)`

439+-- | - Annihiliation: `zero * a = a * zero = zero`

440+class Semiring a where

441+ add :: a -> a -> a

442+ zero :: a

443+ mul :: a -> a -> a

444+ one :: a

445+

446+instance semiringInt :: Semiring Int where

447+ add = intAdd

448+ zero = 0

449+ mul = intMul

450+ one = 1

451+

452+instance semiringNumber :: Semiring Number where

453+ add = numAdd

454+ zero = 0.0

455+ mul = numMul

456+ one = 1.0

457+

458+instance semiringUnit :: Semiring Unit where

459+ add _ _ = unit

460+ zero = unit

461+ mul _ _ = unit

462+ one = unit

463+

464+infixl 6 +

465+infixl 7 *

466+

467+-- | `(+)` is an alias for `add`.

468+(+) :: forall a. (Semiring a) => a -> a -> a

469+(+) = add

470+

471+-- | `(*)` is an alias for `mul`.

472+(*) :: forall a. (Semiring a) => a -> a -> a

473+(*) = mul

474+

475+foreign import intAdd :: Int -> Int -> Int

476+foreign import intMul :: Int -> Int -> Int

477+foreign import numAdd :: Number -> Number -> Number

478+foreign import numMul :: Number -> Number -> Number

479+

480+-- | The `Ring` class is for types that support addition, multiplication,

481+-- | and subtraction operations.

482+-- |

483+-- | Instances must satisfy the following law in addition to the `Semiring`

484+-- | laws:

485+-- |

486+-- | - Additive inverse: `a - a = (zero - a) + a = zero`

487+class (Semiring a) <= Ring a where

488+ sub :: a -> a -> a

489+

490+instance ringInt :: Ring Int where

491+ sub = intSub

492+

493+instance ringNumber :: Ring Number where

494+ sub = numSub

495+

496+instance ringUnit :: Ring Unit where

497+ sub _ _ = unit

498+

499+infixl 6 -

500+

501+-- | `(-)` is an alias for `sub`.

502+(-) :: forall a. (Ring a) => a -> a -> a

503+(-) = sub

504+

505+-- | `negate x` can be used as a shorthand for `zero - x`.

506+negate :: forall a. (Ring a) => a -> a

507+negate a = zero - a

508+

509+foreign import intSub :: Int -> Int -> Int

510+foreign import numSub :: Number -> Number -> Number

511+

512+-- | The `ModuloSemiring` class is for types that support addition,

513+-- | multiplication, division, and modulo (division remainder) operations.

514+-- |

515+-- | Instances must satisfy the following law in addition to the `Semiring`

516+-- | laws:

517+-- |

518+-- | - Remainder: ``a / b * b + (a `mod` b) = a``

519+class (Semiring a) <= ModuloSemiring a where

520+ div :: a -> a -> a

521+ mod :: a -> a -> a

522+

523+instance moduloSemiringInt :: ModuloSemiring Int where

524+ div = intDiv

525+ mod = intMod

526+

527+instance moduloSemiringNumber :: ModuloSemiring Number where

528+ div = numDiv

529+ mod _ _ = 0.0

530+

531+instance moduloSemiringUnit :: ModuloSemiring Unit where

532+ div _ _ = unit

533+ mod _ _ = unit

534+

535+infixl 7 /

536+

537+-- | `(/)` is an alias for `div`.

538+(/) :: forall a. (ModuloSemiring a) => a -> a -> a

539+(/) = div

540+

541+foreign import intDiv :: Int -> Int -> Int

542+foreign import numDiv :: Number -> Number -> Number

543+foreign import intMod :: Int -> Int -> Int

544+

545+-- | A `Ring` where every nonzero element has a multiplicative inverse.

546+-- |

547+-- | Instances must satisfy the following law in addition to the `Ring` and

548+-- | `ModuloSemiring` laws:

549+-- |

550+-- | - Multiplicative inverse: `(one / x) * x = one`

551+-- |

552+-- | As a consequence of this ```a `mod` b = zero``` as no divide operation

553+-- | will have a remainder.

554+class (Ring a, ModuloSemiring a) <= DivisionRing a

555+

556+instance divisionRingNumber :: DivisionRing Number

557+instance divisionRingUnit :: DivisionRing Unit

558+

559+-- | The `Num` class is for types that are commutative fields.

560+-- |

561+-- | Instances must satisfy the following law in addition to the

562+-- | `DivisionRing` laws:

563+-- |

564+-- | - Commutative multiplication: `a * b = b * a`

565+class (DivisionRing a) <= Num a

566+

567+instance numNumber :: Num Number

568+instance numUnit :: Num Unit

569+

570+-- | The `Eq` type class represents types which support decidable equality.

571+-- |

572+-- | `Eq` instances should satisfy the following laws:

573+-- |

574+-- | - Reflexivity: `x == x = true`

575+-- | - Symmetry: `x == y = y == x`

576+-- | - Transitivity: if `x == y` and `y == z` then `x == z`

577+class Eq a where

578+ eq :: a -> a -> Boolean

579+

580+infix 4 ==

581+infix 4 /=

582+

583+-- | `(==)` is an alias for `eq`. Tests whether one value is equal to another.

584+(==) :: forall a. (Eq a) => a -> a -> Boolean

585+(==) = eq

586+

587+-- | `(/=)` tests whether one value is _not equal_ to another. Shorthand for

588+-- | `not (x == y)`.

589+(/=) :: forall a. (Eq a) => a -> a -> Boolean

590+(/=) x y = not (x == y)

591+

592+instance eqBoolean :: Eq Boolean where

593+ eq = refEq

594+

595+instance eqInt :: Eq Int where

596+ eq = refEq

597+

598+instance eqNumber :: Eq Number where

599+ eq = refEq

600+

601+instance eqChar :: Eq Char where

602+ eq = refEq

603+

604+instance eqString :: Eq String where

605+ eq = refEq

606+

607+instance eqUnit :: Eq Unit where

608+ eq _ _ = true

609+

610+instance eqArray :: (Eq a) => Eq (Array a) where

611+ eq = eqArrayImpl (==)

612+

613+instance eqOrdering :: Eq Ordering where

614+ eq LT LT = true

615+ eq GT GT = true

616+ eq EQ EQ = true

617+ eq _ _ = false

618+

619+foreign import refEq :: forall a. a -> a -> Boolean

620+foreign import refIneq :: forall a. a -> a -> Boolean

621+foreign import eqArrayImpl :: forall a. (a -> a -> Boolean) -> Array a -> Array a -> Boolean

622+

623+-- | The `Ordering` data type represents the three possible outcomes of

624+-- | comparing two values:

625+-- |

626+-- | `LT` - The first value is _less than_ the second.

627+-- | `GT` - The first value is _greater than_ the second.

628+-- | `EQ` - The first value is _equal to_ the second.

629+data Ordering = LT | GT | EQ

630+

631+-- | The `Ord` type class represents types which support comparisons with a

632+-- | _total order_.

633+-- |

634+-- | `Ord` instances should satisfy the laws of total orderings:

635+-- |

636+-- | - Reflexivity: `a <= a`

637+-- | - Antisymmetry: if `a <= b` and `b <= a` then `a = b`

638+-- | - Transitivity: if `a <= b` and `b <= c` then `a <= c`

639+class (Eq a) <= Ord a where

640+ compare :: a -> a -> Ordering

641+

642+instance ordBoolean :: Ord Boolean where

643+ compare = unsafeCompare

644+

645+instance ordInt :: Ord Int where

646+ compare = unsafeCompare

647+

648+instance ordNumber :: Ord Number where

649+ compare = unsafeCompare

650+

651+instance ordString :: Ord String where

652+ compare = unsafeCompare

653+

654+instance ordChar :: Ord Char where

655+ compare = unsafeCompare

656+

657+instance ordUnit :: Ord Unit where

658+ compare _ _ = EQ

659+

660+instance ordArray :: (Ord a) => Ord (Array a) where

661+ compare xs ys = compare 0 $ ordArrayImpl (\x y -> case compare x y of

662+ EQ -> 0

663+ LT -> 1

664+ GT -> -1) xs ys

665+

666+foreign import ordArrayImpl :: forall a. (a -> a -> Int) -> Array a -> Array a -> Int

667+

668+instance ordOrdering :: Ord Ordering where

669+ compare LT LT = EQ

670+ compare EQ EQ = EQ

671+ compare GT GT = EQ

672+ compare LT _ = LT

673+ compare EQ LT = GT

674+ compare EQ GT = LT

675+ compare GT _ = GT

676+

677+infixl 4 <

678+infixl 4 >

679+infixl 4 <=

680+infixl 4 >=

681+

682+-- | Test whether one value is _strictly less than_ another.

683+(<) :: forall a. (Ord a) => a -> a -> Boolean

684+(<) a1 a2 = case a1 `compare` a2 of

685+ LT -> true

686+ _ -> false

687+

688+-- | Test whether one value is _strictly greater than_ another.

689+(>) :: forall a. (Ord a) => a -> a -> Boolean

690+(>) a1 a2 = case a1 `compare` a2 of

691+ GT -> true

692+ _ -> false

693+

694+-- | Test whether one value is _non-strictly less than_ another.

695+(<=) :: forall a. (Ord a) => a -> a -> Boolean

696+(<=) a1 a2 = case a1 `compare` a2 of

697+ GT -> false

698+ _ -> true

699+

700+-- | Test whether one value is _non-strictly greater than_ another.

701+(>=) :: forall a. (Ord a) => a -> a -> Boolean

702+(>=) a1 a2 = case a1 `compare` a2 of

703+ LT -> false

704+ _ -> true

705+

706+unsafeCompare :: forall a. a -> a -> Ordering

707+unsafeCompare = unsafeCompareImpl LT EQ GT

708+

709+foreign import unsafeCompareImpl :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering

710+

711+-- | The `Bounded` type class represents types that are finite.

712+-- |

713+-- | Although there are no "internal" laws for `Bounded`, every value of `a`

714+-- | should be considered less than or equal to `top` by some means, and greater

715+-- | than or equal to `bottom`.

716+-- |

717+-- | The lack of explicit `Ord` constraint allows flexibility in the use of

718+-- | `Bounded` so it can apply to total and partially ordered sets, boolean

719+-- | algebras, etc.

720+class Bounded a where

721+ top :: a

722+ bottom :: a

723+

724+instance boundedBoolean :: Bounded Boolean where

725+ top = true

726+ bottom = false

727+

728+instance boundedUnit :: Bounded Unit where

729+ top = unit

730+ bottom = unit

731+

732+instance boundedOrdering :: Bounded Ordering where

733+ top = GT

734+ bottom = LT

735+

736+instance boundedInt :: Bounded Int where

737+ top = topInt

738+ bottom = bottomInt

739+

740+-- | Characters fall within the Unicode range.

741+instance boundedChar :: Bounded Char where

742+ top = topChar

743+ bottom = bottomChar

744+

745+instance boundedFn :: (Bounded b) => Bounded (a -> b) where

746+ top _ = top

747+ bottom _ = bottom

748+

749+foreign import topInt :: Int

750+foreign import bottomInt :: Int

751+

752+foreign import topChar :: Char

753+foreign import bottomChar :: Char

754+

755+-- | The `BoundedOrd` type class represents totally ordered finite data types.

756+-- |

757+-- | Instances should satisfy the following law in addition to the `Ord` laws:

758+-- |

759+-- | - Ordering: `bottom <= a <= top`

760+class (Bounded a, Ord a) <= BoundedOrd a

761+

762+instance boundedOrdBoolean :: BoundedOrd Boolean where

763+instance boundedOrdUnit :: BoundedOrd Unit where

764+instance boundedOrdOrdering :: BoundedOrd Ordering where

765+instance boundedOrdInt :: BoundedOrd Int where

766+instance boundedOrdChar :: BoundedOrd Char where

767+

768+-- | The `BooleanAlgebra` type class represents types that behave like boolean

769+-- | values.

770+-- |

771+-- | Instances should satisfy the following laws in addition to the `Bounded`

772+-- | laws:

773+-- |

774+-- | - Associativity:

775+-- | - `a || (b || c) = (a || b) || c`

776+-- | - `a && (b && c) = (a && b) && c`

777+-- | - Commutativity:

778+-- | - `a || b = b || a`

779+-- | - `a && b = b && a`

780+-- | - Distributivity:

781+-- | - `a && (b || c) = (a && b) || (a && c)`

782+-- | - `a || (b && c) = (a || b) && (a || c)`

783+-- | - Identity:

784+-- | - `a || bottom = a`

785+-- | - `a && top = a`

786+-- | - Idempotent:

787+-- | - `a || a = a`

788+-- | - `a && a = a`

789+-- | - Absorption:

790+-- | - `a || (a && b) = a`

791+-- | - `a && (a || b) = a`

792+-- | - Annhiliation:

793+-- | - `a || top = top`

794+-- | - Complementation:

795+-- | - `a && not a = bottom`

796+-- | - `a || not a = top`

797+class (Bounded a) <= BooleanAlgebra a where

798+ conj :: a -> a -> a

799+ disj :: a -> a -> a

800+ not :: a -> a

801+

802+instance booleanAlgebraBoolean :: BooleanAlgebra Boolean where

803+ conj = boolAnd

804+ disj = boolOr

805+ not = boolNot

806+

807+instance booleanAlgebraUnit :: BooleanAlgebra Unit where

808+ conj _ _ = unit

809+ disj _ _ = unit

810+ not _ = unit

811+

812+instance booleanAlgebraFn :: (BooleanAlgebra b) => BooleanAlgebra (a -> b) where

813+ conj fx fy a = fx a `conj` fy a

814+ disj fx fy a = fx a `disj` fy a

815+ not fx a = not (fx a)

816+

817+infixr 3 &&

818+infixr 2 ||

819+

820+-- | `(&&)` is an alias for `conj`.

821+(&&) :: forall a. (BooleanAlgebra a) => a -> a -> a

822+(&&) = conj

823+

824+-- | `(||)` is an alias for `disj`.

825+(||) :: forall a. (BooleanAlgebra a) => a -> a -> a

826+(||) = disj

827+

828+foreign import boolOr :: Boolean -> Boolean -> Boolean

829+foreign import boolAnd :: Boolean -> Boolean -> Boolean

830+foreign import boolNot :: Boolean -> Boolean

831+

832+-- | The `Show` type class represents those types which can be converted into

833+-- | a human-readable `String` representation.

834+-- |

835+-- | While not required, it is recommended that for any expression `x`, the

836+-- | string `show x` be executable PureScript code which evaluates to the same

837+-- | value as the expression `x`.

838+class Show a where

839+ show :: a -> String

840+

841+instance showBoolean :: Show Boolean where

842+ show true = "true"

843+ show false = "false"

844+

845+instance showInt :: Show Int where

846+ show = showIntImpl

847+

848+instance showNumber :: Show Number where

849+ show = showNumberImpl

850+

851+instance showChar :: Show Char where

852+ show = showCharImpl

853+

854+instance showString :: Show String where

855+ show = showStringImpl

856+

857+instance showUnit :: Show Unit where

858+ show _ = "unit"

859+

860+instance showArray :: (Show a) => Show (Array a) where

861+ show = showArrayImpl show

862+

863+instance showOrdering :: Show Ordering where

864+ show LT = "LT"

865+ show GT = "GT"

866+ show EQ = "EQ"

867+

868+foreign import showIntImpl :: Int -> String

869+foreign import showNumberImpl :: Number -> String

870+foreign import showCharImpl :: Char -> String

871+foreign import showStringImpl :: String -> String

872+foreign import showArrayImpl :: forall a. (a -> String) -> Array a -> String

tests/support/flattened/Test-Assert.jsnew file+27

@@ -0,0 +1,27 @@

1+/* global exports */

2+"use strict";

3+

4+// module Test.Assert

5+

6+exports["assert'"] = function (message) {

7+ return function (success) {

8+ return function () {

9+ if (!success) throw new Error(message);

10+ return {};

11+ };

12+ };

13+};

14+

15+exports.checkThrows = function (fn) {

16+ return function () {

17+ try {

18+ fn();

19+ return false;

20+ } catch (e) {

21+ if (e instanceof Error) return true;

22+ var err = new Error("Threw something other than an Error");

23+ err.something = e;

24+ throw err;

25+ }

26+ };

27+};

tests/support/flattened/Test-Assert.pursnew file+46

@@ -0,0 +1,46 @@

1+module Test.Assert

2+ ( assert'

3+ , assert

4+ , assertThrows

5+ , assertThrows'

6+ , ASSERT()

7+ ) where

8+

9+import Control.Monad.Eff (Eff())

10+import Prelude

11+

12+-- | Assertion effect type.

13+foreign import data ASSERT :: !

14+

15+-- | Throws a runtime exception with message "Assertion failed" when the boolean

16+-- | value is false.

17+assert :: forall e. Boolean -> Eff (assert :: ASSERT | e) Unit

18+assert = assert' "Assertion failed"

19+

20+-- | Throws a runtime exception with the specified message when the boolean

21+-- | value is false.

22+foreign import assert' :: forall e. String -> Boolean -> Eff (assert :: ASSERT | e) Unit

23+

24+-- | Throws a runtime exception with message "Assertion failed: An error should

25+-- | have been thrown", unless the argument throws an exception when evaluated.

26+-- |

27+-- | This function is specifically for testing unsafe pure code; for example,

28+-- | to make sure that an exception is thrown if a precondition is not

29+-- | satisfied. Functions which use `Eff (err :: EXCEPTION | eff) a` can be

30+-- | tested with `catchException` instead.

31+assertThrows :: forall e a. (Unit -> a) -> Eff (assert :: ASSERT | e) Unit

32+assertThrows = assertThrows' "Assertion failed: An error should have been thrown"

33+

34+-- | Throws a runtime exception with the specified message, unless the argument

35+-- | throws an exception when evaluated.

36+-- |

37+-- | This function is specifically for testing unsafe pure code; for example,

38+-- | to make sure that an exception is thrown if a precondition is not

39+-- | satisfied. Functions which use `Eff (err :: EXCEPTION | eff) a` can be

40+-- | tested with `catchException` instead.

41+assertThrows' :: forall e a. String -> (Unit -> a) -> Eff (assert :: ASSERT | e) Unit

42+assertThrows' msg fn =

43+ checkThrows fn >>= assert' msg

44+

45+

46+foreign import checkThrows :: forall e a. (Unit -> a) -> Eff (assert :: ASSERT | e) Boolean

psci/tests/data/Sample.purs → tests/support/psci/Sample.pursrenamed

The content is the same.

travis/after.sh+5−17

@@ -4,22 +4,10 @@ pushd core-tests/

4./test-everything.sh

5popd

6

7−if ! git describe --tags --exact-match >/dev/null 2>/dev/null && [ -n "$COVERAGE_SUITE" ]

7+if ! git describe --tags --exact-match >/dev/null 2>/dev/null && [ "$COVERAGE" = "true" ]

8then

9− case "$COVERAGE_SUITE" in

10− "tests")

11− ./.cabal-sandbox/bin/hpc-coveralls \

9+ ./.cabal-sandbox/bin/hpc-coveralls \

12− --exclude-dir=dist/build/autogen \

13− --exclude-dir=tests \

14− tests;;

15− "psci-tests")

16− ./.cabal-sandbox/bin/hpc-coveralls \

17− --exclude-dir=dist/build/autogen \

10+ --exclude-dir=dist/build/autogen \

18− --exclude-dir=src \

19− --exclude-dir=psci/tests \

11+ --exclude-dir=tests \

20− psci-tests;;

12+ tests

21− *)

22− echo "unrecognised test suite $COVERAGE_SUITE"

23− exit 1;;

24− esac

25fi

13fi

travis/configure.sh+1−1

@@ -8,7 +8,7 @@ then

8 configure_flags="--disable-optimization $configure_flags"

9fi

10

11−if [ -n "$COVERAGE_SUITE" ]

11+if [ "$COVERAGE" = "true" ]

12then

13 configure_flags="--enable-coverage $configure_flags"

14fi