7e46b25 · rowtype-yoga/purescript-native

CONTRIBUTORS.md+3

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

63- [@paulyoung](https://github.com/paulyoung) (Paul Young) My existing contributions and all future contributions until further notice are Copyright Paul Young, 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).

64- [@pelotom](https://github.com/pelotom) (Thomas Crockett) My existing contributions and all future contributions until further notice are Copyright Thomas Crockett, 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).

65- [@phadej](https://github.com/phadej) (Oleg Grenrus) My existing contributions and all future contributions until further notice are Copyright Oleg Grenrus, 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+- [@phiggins](https://github.com/phiggins) (Pete Higgins) My existing contributions and all future contributions until further notice are Copyright Pete Higgins, 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- [@philopon](https://github.com/philopon) (Hirotomo Moriwaki) - My existing contributions and all future contributions until further notice are Copyright Hirotomo Moriwaki, 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- [@philopon](https://github.com/philopon) (Hirotomo Moriwaki) - My existing contributions and all future contributions until further notice are Copyright Hirotomo Moriwaki, 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- [@pseudonom](https://github.com/pseudonom) (Eric Easley) My existing contributions and all future contributions until further notice are Copyright Eric Easley, 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- [@pseudonom](https://github.com/pseudonom) (Eric Easley) My existing contributions and all future contributions until further notice are Copyright Eric Easley, 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- [@puffnfresh](https://github.com/puffnfresh) (Brian McKenna) All contributions I made during June 2015 were during employment at [SlamData, Inc.](#companies) who owns the copyright. I assign copyright of all my personal contributions before June 2015 to the owners of the PureScript compiler.

69- [@puffnfresh](https://github.com/puffnfresh) (Brian McKenna) All contributions I made during June 2015 were during employment at [SlamData, Inc.](#companies) who owns the copyright. I assign copyright of all my personal contributions before June 2015 to the owners of the PureScript compiler.

@@ -81,6 +82,8 @@ This file lists the contributors to the PureScript compiler project, and the ter

81- [@utkarshkukreti](https://github.com/utkarshkukreti) (Utkarsh Kukreti) My existing contributions and all future contributions until further notice are Copyright Utkarsh Kukreti, 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).

82- [@utkarshkukreti](https://github.com/utkarshkukreti) (Utkarsh Kukreti) My existing contributions and all future contributions until further notice are Copyright Utkarsh Kukreti, 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).

82- [@vkorablin](https://github.com/vkorablin) (Vladimir Korablin) - My existing contributions and all future contributions until further notice are Copyright Vladimir Korablin, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.

83- [@vkorablin](https://github.com/vkorablin) (Vladimir Korablin) - My existing contributions and all future contributions until further notice are Copyright Vladimir Korablin, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.

83- [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, 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).

84- [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, 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).

85+- [@brandonhamilton](https://github.com/brandonhamilton) (Brandon Hamilton) My existing contributions and all future contributions until further notice are Copyright Brandon Hamilton, 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).

86+- [@bbqbaron](https://github.com/bbqbaron) (Eric Loren) My existing contributions and all future contributions until further notice are Copyright Eric Loren, 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).

84

87

85### Companies

88### Companies

86

89

examples/failing/2378.pursnew file+6

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

1+-- @shouldFailWith OrphanInstance

2+module Main where

3+

4+import Lib

5+

6+instance fooX :: Foo "x"

examples/failing/2378/Lib.pursnew file+3

@@ -0,0 +1,3 @@

1+module Lib (class Foo) where

2+

3+class Foo (a :: Symbol)

examples/failing/2379.pursnew file+6

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

1+-- @shouldFailWith UnknownClass

2+module Main where

3+

4+import Lib

5+

6+test = x [1, 2, 3]

examples/failing/2379/Lib.pursnew file+9

@@ -0,0 +1,9 @@

1+module Lib (class X, x) where

2+

3+class X a where

4+ x :: a -> String

5+

6+class Y a

7+

8+instance xArray :: Y a => X (Array a) where

9+ x _ = "[]"

examples/failing/ConstraintFailure.pursnew file+13

@@ -0,0 +1,13 @@

1+-- @shouldFailWith NoInstanceFound

2+

3+module Main where

4+

5+import Prelude

6+

7+data Foo = Bar

8+

9+spin :: forall a. a -> Foo

10+spin x = Bar

11+

12+main = show <<< spin

13+

examples/failing/ConstraintInference.purs+1−1

@@ -1,4 +1,4 @@

1−-- @shouldFailWith NoInstanceFound

1+-- @shouldFailWith AmbiguousTypeVariables

2

3module Main where

4

examples/failing/NonWildcardNewtypeInstance.purs+1−1

@@ -1,4 +1,4 @@

1−-- @shouldFailWith NonWildcardNewtypeInstance

1+-- @shouldFailWith ExpectedWildcard

2module NonWildcardNewtypeInstance where

3

4import Data.Newtype

examples/passing/2378.pursnew file+9

@@ -0,0 +1,9 @@

1+module Main where

2+

3+import Control.Monad.Eff.Console (log)

4+

5+class Foo (a :: Symbol)

6+

7+instance fooX :: Foo "x"

8+

9+main = log "Done"

examples/passing/DctorName.pursnew file+33

@@ -0,0 +1,33 @@

1+module Main where

2+

3+import Prelude

4+import Control.Monad.Eff.Console (log)

5+

6+newtype Bar' = Bar' Int

7+

8+data Foo' = Foo' Bar'

9+

10+data Baz'' = Baz'' | Baz'

11+

12+f ∷ Foo' → Boolean

13+f a = case a of Foo' b → true

14+

15+f' ∷ Boolean

16+f' = f $ Foo' $ Bar' 0

17+

18+g ∷ Baz'' → Int

19+g Baz'' = 0

20+g Baz' = 1

21+

22+g' ∷ Int

23+g' = g Baz''

24+

25+h ∷ Bar' → Int

26+h (Bar' x)

27+ | x <= 10 = x * 2

28+ | otherwise = 10

29+

30+h' ∷ Int

31+h' = h $ Bar' 4

32+

33+main = log "Done"

examples/passing/GHCGenerics.pursdeleted−140

@@ -1,140 +0,0 @@

1−-- An example to show how we could implement GHC-style Generics using

2−-- functional dependencies.

3−--

4−-- See https://hackage.haskell.org/package/base-4.9.0.0/docs/GHC-Generics.html

5−

6−module Main where

7−

8−import Prelude

9−import Control.Monad.Eff (Eff)

10−import Control.Monad.Eff.Console (CONSOLE, log, logShow)

11−

12−-- Representation for types with no constructors

13−data V1

14−

15−-- Representation for constructors with no arguments

16−data U1 = U1

17−

18−-- Representation for sum types

19−data Sum a b = Inl a | Inr b

20−

21−infixr 5 type Sum as +

22−

23−-- Representation for product types

24−data Product a b = Product a b

25−

26−infixr 6 type Product as *

27−

28−-- Representation for data constructors, with the data constructor name indicated

29−-- at the type level.

30−data Ctor (name :: Symbol) a = Ctor a

31−

32−-- Representation for occurrences of other types in a data type definition.

33−data K a = K a

34−

35−-- The Generic class asserts the existence of a type function from "real" types

36−-- to representation types, and an isomorphism between them.

37−class Generic a repr | a -> repr where

38− to :: a -> repr

39− from :: repr -> a

40−

41−-- We can write an instance for the (recursive) type of lists. Note that these

42−-- instances would be generated by the compiler ideally.

43−data List a = Nil | Cons a (List a)

44−

45−instance genericList :: Generic (List a) (Ctor "Nil" U1 + Ctor "Cons" (K a * K (List a))) where

46− to Nil = Inl (Ctor U1)

47− to (Cons x xs) = Inr (Ctor (Product (K x) (K xs)))

48− from (Inl (Ctor U1)) = Nil

49− from (Inr (Ctor (Product (K x) (K xs)))) = Cons x xs

50−

51−-- We'd like to refect type level strings (for data constructor names) at the value

52−-- level, so that we can "show" them. Again, these instances would ideally be derived

53−-- for us.

54−class KnownSymbol (sym :: Symbol) where

55− symbol :: forall proxy. proxy sym -> String

56−

57−instance knownSymbolNil :: KnownSymbol "Nil" where

58− symbol _ = "Nil"

59−

60−instance knownSymbolCons :: KnownSymbol "Cons" where

61− symbol _ = "Cons"

62−

63−-- A proxy for a type-level string.

64−data SProxy (sym :: Symbol) = SProxy

65−

66−-- To write generic functions, we create a corresponding type class, and use the

67−-- type class machinery to infer the correct function based on the representation

68−-- type.

69−class GShow a where

70− gShow :: a -> String

71−

72−-- Now provide instances for GShow for the appropriate representation types.

73−-- Note: we don't have to implement all instances here.

74−

75−instance gShowU1 :: GShow U1 where

76− gShow _ = ""

77−

78−instance gShowSum :: (GShow a, GShow b) => GShow (a + b) where

79− gShow (Inl a) = gShow a

80− gShow (Inr b) = gShow b

81−

82−instance gShowProduct :: (GShow a, GShow b) => GShow (a * b) where

83− gShow (Product a b) = gShow a <> gShow b

84−

85−instance gShowCtor :: (KnownSymbol ctor, GShow a) => GShow (Ctor ctor a) where

86− gShow (Ctor a) = "(" <> symbol (SProxy :: SProxy ctor) <> gShow a <> ")"

87−

88−instance gShowK :: Show a => GShow (K a) where

89− gShow (K a) = " " <> show a

90−

91−-- Now we can implement a generic show function which uses the GShow instance

92−-- on the representation type.

93−genericShow :: forall a repr. (Generic a repr, GShow repr) => a -> String

94−genericShow x = gShow (to x)

95−

96−-- Note how the required instance here is Show a, and not Generic a.

97−-- This allows us to use generic programming on a wider variety of types

98−-- (including types which contain foreign types) than we can use now.

99−instance showList :: Show a => Show (List a) where

100− show xs = genericShow xs -- (we need to eta expand here to avoid stack overflow

101− -- due to recursion implicit in the instance lookup)

102−

103−-- Another example: Eq

104−

105−class GEq a where

106− gEq :: a -> a -> Boolean

107−

108−instance gEqU1 :: GEq U1 where

109− gEq _ _ = true

110−

111−instance gEqSum :: (GEq a, GEq b) => GEq (a + b) where

112− gEq (Inl a1) (Inl a2) = gEq a1 a2

113− gEq (Inr b1) (Inr b2) = gEq b1 b2

114− gEq _ _ = false

115−

116−instance gEqProduct :: (GEq a, GEq b) => GEq (a * b) where

117− gEq (Product a1 b1) (Product a2 b2) = gEq a1 a2 && gEq b1 b2

118−

119−instance gEqCtor :: (KnownSymbol ctor, GEq a) => GEq (Ctor ctor a) where

120− gEq (Ctor a1) (Ctor a2) = gEq a1 a2

121−

122−instance gEqK :: Eq a => GEq (K a) where

123− gEq (K a1) (K a2) = a1 == a2

124−

125−genericEq :: forall a repr. (Generic a repr, GEq repr) => a -> a -> Boolean

126−genericEq x y = gEq (to x) (to y)

127−

128−instance eqList :: Eq a => Eq (List a) where

129− eq xs ys = genericEq xs ys

130−

131−main :: Eff (console :: CONSOLE) Unit

132−main = do

133− logShow (Cons 1 Nil)

134− logShow (Cons 1 (Cons 2 Nil))

135− logShow (Cons 'x' (Cons 'y' (Cons 'z' Nil)))

136−

137− logShow (Cons 1 (Cons 2 Nil) == Cons 1 (Cons 2 Nil))

138− logShow (Cons 1 (Cons 2 Nil) == Cons 1 Nil)

139−

140− log "Done"

examples/passing/GenericsRep.pursnew file+53

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

1+module Main where

2+

3+import Prelude

4+import Control.Monad.Eff (Eff)

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

6+import Data.Generic.Rep (class Generic)

7+import Data.Generic.Rep.Eq (genericEq)

8+

9+data X a = X a

10+

11+derive instance genericX :: Generic (X a) _

12+

13+instance eqX :: Eq a => Eq (X a) where

14+ eq xs ys = genericEq xs ys

15+

16+data Y a = Y | Z a (Y a)

17+

18+derive instance genericY :: Generic (Y a) _

19+

20+instance eqY :: Eq a => Eq (Y a) where

21+ eq xs ys = genericEq xs ys

22+

23+data Z

24+

25+derive instance genericZ :: Generic Z _

26+

27+instance eqZ :: Eq Z where

28+ eq x y = genericEq x y

29+

30+newtype W = W { x :: Int, y :: String }

31+

32+derive instance genericW :: Generic W _

33+

34+instance eqW :: Eq W where

35+ eq x y = genericEq x y

36+

37+data V = V { x :: Int } { x :: Int }

38+

39+derive instance genericV :: Generic V _

40+

41+instance eqV :: Eq V where

42+ eq x y = genericEq x y

43+

44+main :: Eff (console :: CONSOLE) Unit

45+main = do

46+ logShow (X 0 == X 1)

47+ logShow (X 1 == X 1)

48+ logShow (Z 1 Y == Z 1 Y)

49+ logShow (Z 1 Y == Y)

50+ logShow (Y == Y :: Y Z)

51+ logShow (W { x: 0, y: "A" } == W { x: 0, y: "A" })

52+ logShow (V { x: 0 } { x: 0 } == V { x: 0 } { x: 0 })

53+ log "Done"

examples/passing/RowsInInstanceContext.pursnew file+25

@@ -0,0 +1,25 @@

1+module Main where

2+

3+import Prelude

4+import Control.Monad.Eff (Eff)

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

6+import Data.Newtype (class Newtype, unwrap)

7+

8+class TypeEquals a b | a -> b, b -> a where

9+ coerce :: a -> b

10+ coerceBack :: b -> a

11+

12+instance refl :: TypeEquals a a where

13+ coerce = id

14+ coerceBack = id

15+

16+newtype RecordNewtype = RecordNewtype { x :: String }

17+

18+instance newtypeRecordNewtype ::

19+ TypeEquals inner { x :: String }

20+ => Newtype RecordNewtype inner where

21+ wrap = RecordNewtype <<< coerce

22+ unwrap (RecordNewtype rec) = coerceBack rec

23+

24+main :: Eff (console :: CONSOLE) Unit

25+main = log (unwrap (RecordNewtype { x: "Done" })).x

examples/warning/2383.pursnew file+12

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

1+-- | This specifically shouldn't warn about `x` being shadowed in `main`

2+-- | See https://github.com/purescript/purescript/issues/2383

3+module Main where

4+

5+import Prelude

6+

7+import Control.Monad.Eff (Eff)

8+

9+main :: Eff () Unit

10+main = do

11+ x <- let x = pure unit in x

12+ pure unit

examples/warning/2411.pursnew file+15

@@ -0,0 +1,15 @@

1+-- @shouldWarnWith ShadowedName

2+module Main where

3+

4+import Prelude

5+

6+import Control.Monad.Eff (Eff)

7+

8+test :: forall m. Monad m => Int -> m Unit

9+test x =

10+ let x = unit

11+ in pure x

12+

13+main :: Eff () Unit

14+main = test 42

15+

hierarchy/Main.hs+2−2

@@ -33,7 +33,7 @@ import System.FilePath ((</>))

33import System.FilePath.Glob (glob)

34import System.Exit (exitFailure, exitSuccess)

35import System.IO (hPutStr, stderr)

36−import System.IO.UTF8 (readUTF8File)

36+import System.IO.UTF8 (readUTF8FileT)

37

38import qualified Language.PureScript as P

39import qualified Paths_purescript as Paths

@@ -60,7 +60,7 @@ runModuleName (P.ModuleName pns) = intercalate "_" (P.runProperName `map` pns)

60

61readInput :: [FilePath] -> IO (Either P.MultipleErrors [P.Module])

62readInput paths = do

63− content <- mapM (\path -> (path, ) <$> readUTF8File path) paths

63+ content <- mapM (\path -> (path, ) <$> readUTF8FileT path) paths

64 return $ map snd <$> P.parseModulesFromFiles id content

65

66compile :: HierarchyOptions -> IO ()

psc-docs/Main.hs+7−6

@@ -7,6 +7,7 @@ import Control.Monad.Trans.Except (runExceptT)

7import Control.Arrow (first, second)

8import Control.Category ((>>>))

9import Control.Monad.Writer

10+import Data.Text (Text)

10import Data.Function (on)

11import Data.Function (on)

11import Data.List

12import Data.List

12import Data.Maybe (fromMaybe)

13import Data.Maybe (fromMaybe)

@@ -20,7 +21,7 @@ import qualified Language.PureScript as P

20import qualified Paths_purescript as Paths

21import qualified Paths_purescript as Paths

21import System.Exit (exitFailure)

22import System.Exit (exitFailure)

22import System.IO (hPutStrLn, hPrint, hSetEncoding, stderr, stdout, utf8)

23import System.IO (hPutStrLn, hPrint, hSetEncoding, stderr, stdout, utf8)

23−import System.IO.UTF8 (readUTF8File)

24+import System.IO.UTF8 (readUTF8FileT)

24import System.Directory (createDirectoryIfMissing)

25import System.Directory (createDirectoryIfMissing)

25import System.FilePath (takeDirectory)

26import System.FilePath (takeDirectory)

26import System.FilePath.Glob (glob)

27import System.FilePath.Glob (glob)

@@ -139,8 +140,8 @@ dumpTags input renderTags = do

139 ldump :: [String] -> IO ()

140 ldump :: [String] -> IO ()

140 ldump = mapM_ putStrLn

141 ldump = mapM_ putStrLn

141

142

142−parseFile :: FilePath -> IO (FilePath, String)

143+parseFile :: FilePath -> IO (FilePath, Text)

143−parseFile input = (,) input <$> readUTF8File input

144+parseFile input = (,) input <$> readUTF8FileT input

144

145

145inputFile :: Parser FilePath

146inputFile :: Parser FilePath

146inputFile = strArgument $

147inputFile = strArgument $

@@ -235,16 +236,16 @@ examples =

235 PP.vcat $ map PP.text

236 PP.vcat $ map PP.text

236 [ "Examples:"

237 [ "Examples:"

237 , " print documentation for Data.List to stdout:"

238 , " print documentation for Data.List to stdout:"

238− , " psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\"

239+ , " psc-docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\"

239 , " --docgen Data.List"

240 , " --docgen Data.List"

240 , ""

241 , ""

241 , " write documentation for Data.List to docs/Data.List.md:"

242 , " write documentation for Data.List to docs/Data.List.md:"

242− , " psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\"

243+ , " psc-docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\"

243 , " --docgen Data.List:docs/Data.List.md"

244 , " --docgen Data.List:docs/Data.List.md"

244 , ""

245 , ""

245 , " write documentation for Data.List to docs/Data.List.md, and"

246 , " write documentation for Data.List to docs/Data.List.md, and"

246 , " documentation for Data.List.Lazy to docs/Data.List.Lazy.md:"

247 , " documentation for Data.List.Lazy to docs/Data.List.Lazy.md:"

247− , " psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\"

248+ , " psc-docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\"

248 , " --docgen Data.List:docs/Data.List.md \\"

249 , " --docgen Data.List:docs/Data.List.md \\"

249 , " --docgen Data.List.Lazy:docs/Data.List.Lazy.md"

250 , " --docgen Data.List.Lazy:docs/Data.List.Lazy.md"

250 ]

251 ]

psc-package/Main.hsnew file+259

@@ -0,0 +1,259 @@

1+{-# LANGUAGE DeriveAnyClass #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE NamedFieldPuns #-}

4+{-# LANGUAGE OverloadedStrings #-}

5+{-# LANGUAGE RecordWildCards #-}

6+{-# LANGUAGE TupleSections #-}

7+

8+module Main where

9+

10+import qualified Data.Aeson as Aeson

11+import Data.Aeson.Encode.Pretty

12+import Data.Foldable (fold, for_, traverse_)

13+import Data.List (nub)

14+import qualified Data.Map as Map

15+import Data.Maybe (mapMaybe)

16+import qualified Data.Set as Set

17+import Data.Text (pack)

18+import qualified Data.Text.Lazy as TL

19+import qualified Data.Text.Lazy.Builder as TB

20+import Data.Text.Encoding (encodeUtf8)

21+import Data.Traversable (for)

22+import Data.Version (showVersion)

23+import qualified Filesystem.Path.CurrentOS as Path

24+import GHC.Generics (Generic)

25+import qualified Options.Applicative as Opts

26+import qualified Paths_purescript as Paths

27+import qualified System.IO as IO

28+import Turtle hiding (fold)

29+

30+packageFile :: Path.FilePath

31+packageFile = "psc-package.json"

32+

33+data PackageConfig = PackageConfig

34+ { name :: Text

35+ , depends :: [Text]

36+ , set :: Text

37+ , source :: Text

38+ } deriving (Show, Generic, Aeson.FromJSON, Aeson.ToJSON)

39+

40+pathToTextUnsafe :: Turtle.FilePath -> Text

41+pathToTextUnsafe = either (error "Path.toText failed") id . Path.toText

42+

43+defaultPackage :: Text -> PackageConfig

44+defaultPackage pkgName =

45+ PackageConfig { name = pkgName

46+ , depends = [ "prelude" ]

47+ , set = "psc-" <> pack (showVersion Paths.version)

48+ , source = "https://github.com/purescript/package-sets.git"

49+ }

50+

51+readPackageFile :: IO PackageConfig

52+readPackageFile = do

53+ exists <- testfile packageFile

54+ unless exists $ do

55+ echo "psc-package.json does not exist"

56+ exit (ExitFailure 1)

57+ mpkg <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile packageFile

58+ case mpkg of

59+ Nothing -> do

60+ echo "Unable to parse psc-package.json"

61+ exit (ExitFailure 1)

62+ Just pkg -> return pkg

63+

64+encodePrettyToText :: Aeson.ToJSON json => json -> Text

65+encodePrettyToText =

66+ TL.toStrict

67+ . TB.toLazyText

68+ . encodePrettyToTextBuilder' config

69+ where

70+ config = defConfig

71+ { confCompare =

72+ keyOrder [ "name"

73+ , "set"

74+ , "source"

75+ , "depends"

76+ ]

77+ }

78+

79+writePackageFile :: PackageConfig -> IO ()

80+writePackageFile =

81+ writeTextFile packageFile

82+ . encodePrettyToText

83+

84+data PackageInfo = PackageInfo

85+ { repo :: Text

86+ , version :: Text

87+ , dependencies :: [Text]

88+ } deriving (Show, Eq, Generic, Aeson.FromJSON, Aeson.ToJSON)

89+

90+type PackageSet = Map.Map Text PackageInfo

91+

92+cloneShallow

93+ :: Text

94+ -- ^ repo

95+ -> Text

96+ -- ^ branch/tag

97+ -> Turtle.FilePath

98+ -- ^ target directory

99+ -> IO ExitCode

100+cloneShallow from ref into =

101+ proc "git"

102+ [ "clone"

103+ , "-q"

104+ , "-c", "advice.detachedHead=false"

105+ , "--depth", "1"

106+ , "-b", ref

107+ , from

108+ , pathToTextUnsafe into

109+ ] empty .||. exit (ExitFailure 1)

110+

111+getPackageSet :: PackageConfig -> IO ()

112+getPackageSet PackageConfig{ source, set } = do

113+ let pkgDir = ".psc-package" </> fromText set </> ".set"

114+ exists <- testdir pkgDir

115+ unless exists . void $ cloneShallow source set pkgDir

116+

117+readPackageSet :: PackageConfig -> IO PackageSet

118+readPackageSet PackageConfig{ set } = do

119+ let dbFile = ".psc-package" </> fromText set </> ".set" </> "packages.json"

120+ exists <- testfile dbFile

121+ unless exists $ do

122+ echo "packages.json does not exist"

123+ exit (ExitFailure 1)

124+ mdb <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile dbFile

125+ case mdb of

126+ Nothing -> do

127+ echo "Unable to parse packages.json"

128+ exit (ExitFailure 1)

129+ Just db -> return db

130+

131+installOrUpdate :: PackageConfig -> Text -> PackageInfo -> IO ()

132+installOrUpdate PackageConfig{ set } pkgName PackageInfo{ repo, version } = do

133+ let pkgDir = ".psc-package" </> fromText set </> fromText pkgName </> fromText version

134+ exists <- testdir pkgDir

135+ unless exists . void $ cloneShallow repo version pkgDir

136+

137+getTransitiveDeps :: PackageSet -> [Text] -> IO [(Text, PackageInfo)]

138+getTransitiveDeps db depends = do

139+ pkgs <- for depends $ \pkg ->

140+ case Map.lookup pkg db of

141+ Nothing -> do

142+ echo ("Package " <> pkg <> " does not exist in package set")

143+ exit (ExitFailure 1)

144+ Just PackageInfo{ dependencies } -> return (pkg : dependencies)

145+ let unique = Set.toList (foldMap Set.fromList pkgs)

146+ return (mapMaybe (\name -> fmap (name, ) (Map.lookup name db)) unique)

147+

148+updateImpl :: PackageConfig -> IO ()

149+updateImpl config@PackageConfig{ depends } = do

150+ getPackageSet config

151+ db <- readPackageSet config

152+ trans <- getTransitiveDeps db depends

153+ echo ("Updating " <> pack (show (length trans)) <> " packages...")

154+ for_ trans $ \(pkgName, pkg) -> do

155+ echo ("Updating " <> pkgName)

156+ installOrUpdate config pkgName pkg

157+

158+initialize :: IO ()

159+initialize = do

160+ exists <- testfile "psc-package.json"

161+ when exists $ do

162+ echo "psc-package.json already exists"

163+ exit (ExitFailure 1)

164+ echo "Initializing new project in current directory"

165+ pkgName <- pathToTextUnsafe . Path.filename <$> pwd

166+ let pkg = defaultPackage pkgName

167+ writePackageFile pkg

168+ updateImpl pkg

169+

170+update :: IO ()

171+update = do

172+ pkg <- readPackageFile

173+ updateImpl pkg

174+ echo "Update complete"

175+

176+install :: String -> IO ()

177+install pkgName = do

178+ pkg <- readPackageFile

179+ let pkg' = pkg { depends = nub (pack pkgName : depends pkg) }

180+ updateImpl pkg'

181+ writePackageFile pkg'

182+ echo "psc-package.json file was updated"

183+

184+listDependencies :: IO ()

185+listDependencies = do

186+ pkg@PackageConfig{ depends } <- readPackageFile

187+ db <- readPackageSet pkg

188+ trans <- getTransitiveDeps db depends

189+ traverse_ (echo . fst) trans

190+

191+getSourcePaths :: PackageConfig -> PackageSet -> [Text] -> IO [Turtle.FilePath]

192+getSourcePaths PackageConfig{..} db pkgNames = do

193+ trans <- getTransitiveDeps db pkgNames

194+ let paths = [ ".psc-package"

195+ </> fromText set

196+ </> fromText pkgName

197+ </> fromText version

198+ </> "src" </> "**" </> "*.purs"

199+ | (pkgName, PackageInfo{ version }) <- trans

200+ ]

201+ return paths

202+

203+listSourcePaths :: IO ()

204+listSourcePaths = do

205+ pkg@PackageConfig{ depends } <- readPackageFile

206+ db <- readPackageSet pkg

207+ paths <- getSourcePaths pkg db depends

208+ traverse_ (echo . pathToTextUnsafe) paths

209+

210+exec :: Text -> IO ()

211+exec exeName = do

212+ pkg@PackageConfig{..} <- readPackageFile

213+ db <- readPackageSet pkg

214+ paths <- getSourcePaths pkg db depends

215+ procs exeName

216+ (map pathToTextUnsafe ("src" </> "**" </> "*.purs" : paths))

217+ empty

218+

219+main :: IO ()

220+main = do

221+ IO.hSetEncoding IO.stdout IO.utf8

222+ IO.hSetEncoding IO.stderr IO.utf8

223+ cmd <- Opts.execParser opts

224+ cmd

225+ where

226+ opts = Opts.info (versionInfo <*> Opts.helper <*> commands) infoModList

227+ infoModList = Opts.fullDesc <> headerInfo <> footerInfo

228+ headerInfo = Opts.progDesc "Manage package dependencies"

229+ footerInfo = Opts.footer $ "psc-package " ++ showVersion Paths.version

230+

231+ versionInfo :: Parser (a -> a)

232+ versionInfo = Opts.abortOption (Opts.InfoMsg (showVersion Paths.version)) $

233+ Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden

234+

235+ commands :: Parser (IO ())

236+ commands = (Opts.subparser . fold)

237+ [ Opts.command "init"

238+ (Opts.info (pure initialize)

239+ (Opts.progDesc "Initialize a new package"))

240+ , Opts.command "update"

241+ (Opts.info (pure update)

242+ (Opts.progDesc "Update dependencies"))

243+ , Opts.command "install"

244+ (Opts.info (install <$> pkg)

245+ (Opts.progDesc "Install the named package"))

246+ , Opts.command "build"

247+ (Opts.info (pure (exec "psc"))

248+ (Opts.progDesc "Build the current package and dependencies"))

249+ , Opts.command "dependencies"

250+ (Opts.info (pure listDependencies)

251+ (Opts.progDesc "List all (transitive) dependencies for the current package"))

252+ , Opts.command "sources"

253+ (Opts.info (pure listSourcePaths)

254+ (Opts.progDesc "List all (active) source paths for dependencies"))

255+ ]

256+ where

257+ pkg = Opts.strArgument $

258+ Opts.metavar "PACKAGE"

259+ <> Opts.help "The name of the package to install"

psc/Main.hs+4−3

@@ -15,6 +15,7 @@ import Data.Bool (bool)

15import qualified Data.ByteString.Lazy as B

16import qualified Data.ByteString.UTF8 as BU8

17import qualified Data.Map as M

18+import Data.Text (Text)

18import Data.Version (showVersion)

19import Data.Version (showVersion)

19

20

20import qualified Language.PureScript as P

21import qualified Language.PureScript as P

@@ -29,7 +30,7 @@ import qualified System.Console.ANSI as ANSI

29import System.Exit (exitSuccess, exitFailure)

30import System.Exit (exitSuccess, exitFailure)

30import System.FilePath.Glob (glob)

31import System.FilePath.Glob (glob)

31import System.IO (hSetEncoding, hPutStrLn, stdout, stderr, utf8)

32import System.IO (hSetEncoding, hPutStrLn, stdout, stderr, utf8)

32−import System.IO.UTF8

33+import System.IO.UTF8 (readUTF8FileT)

33

34

34data PSCMakeOptions = PSCMakeOptions

35data PSCMakeOptions = PSCMakeOptions

35 { pscmInput :: [FilePath]

36 { pscmInput :: [FilePath]

@@ -85,8 +86,8 @@ globWarningOnMisses warn = concatMapM globWithWarning

85 return paths

86 return paths

86 concatMapM f = fmap concat . mapM f

87 concatMapM f = fmap concat . mapM f

87

88

88−readInput :: [FilePath] -> IO [(FilePath, String)]

89+readInput :: [FilePath] -> IO [(FilePath, Text)]

89−readInput inputFiles = forM inputFiles $ \inFile -> (inFile, ) <$> readUTF8File inFile

90+readInput inputFiles = forM inputFiles $ \inFile -> (inFile, ) <$> readUTF8FileT inFile

90

91

91inputFile :: Parser FilePath

92inputFile :: Parser FilePath

92inputFile = strArgument $

93inputFile = strArgument $

psci/Main.hs+29−22

@@ -63,17 +63,10 @@ import System.Process (readProcessWithExitCode)

63

64-- | Command line options

65data PSCiOptions = PSCiOptions

66− { psciMultiLineMode :: Bool

67− , psciInputFile :: [FilePath]

66+ { psciInputFile :: [FilePath]

68 , psciBackend :: Backend

67 , psciBackend :: Backend

69 }

68 }

70

69

71−multiLineMode :: Opts.Parser Bool

72−multiLineMode = Opts.switch $

73− Opts.long "multi-line-mode"

74− <> Opts.short 'm'

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

76−

77inputFile :: Opts.Parser FilePath

70inputFile :: Opts.Parser FilePath

78inputFile = Opts.strArgument $

71inputFile = Opts.strArgument $

79 Opts.metavar "FILE"

72 Opts.metavar "FILE"

@@ -100,8 +93,7 @@ backend =

100 <|> (nodeBackend <$> nodeFlagsFlag)

93 <|> (nodeBackend <$> nodeFlagsFlag)

101

94

102psciOptions :: Opts.Parser PSCiOptions

95psciOptions :: Opts.Parser PSCiOptions

103−psciOptions = PSCiOptions <$> multiLineMode

96+psciOptions = PSCiOptions <$> many inputFile

104− <*> many inputFile

105 <*> backend

97 <*> backend

106

98

107version :: Opts.Parser (a -> a)

99version :: Opts.Parser (a -> a)

@@ -119,17 +111,20 @@ getOpt = Opts.execParser opts

119 footerInfo = Opts.footer $ "psci " ++ showVersion Paths.version

111 footerInfo = Opts.footer $ "psci " ++ showVersion Paths.version

120

112

121-- | Parses the input and returns either a command, or an error as a 'String'.

113-- | Parses the input and returns either a command, or an error as a 'String'.

122−getCommand :: forall m. MonadException m => Bool -> InputT m (Either String (Maybe Command))

114+getCommand :: forall m. MonadException m => InputT m (Either String (Maybe Command))

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

115+getCommand = handleInterrupt (return (Right Nothing)) $ do

124− firstLine <- withInterrupt $ getInputLine "> "

116+ line <- withInterrupt $ getInputLine "> "

125− case firstLine of

117+ case line of

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

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

127 Just "" -> return (Right Nothing)

119 Just "" -> return (Right Nothing)

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

120+ Just s -> return . fmap Just $ parseCommand s

121+

122+pasteMode :: forall m. MonadException m => InputT m (Either String Command)

123+pasteMode =

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

124+ parseCommand <$> go []

130 where

125 where

131 go :: [String] -> InputT m String

126 go :: [String] -> InputT m String

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

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

133

128

134-- | Make a JavaScript bundle for the browser.

129-- | Make a JavaScript bundle for the browser.

135bundle :: IO (Either Bundle.ErrorMessage String)

130bundle :: IO (Either Bundle.ErrorMessage String)

@@ -349,16 +344,28 @@ main = getOpt >>= loop

349

344

350 go :: state -> InputT (StateT PSCiState (ReaderT PSCiConfig IO)) ()

345 go :: state -> InputT (StateT PSCiState (ReaderT PSCiConfig IO)) ()

351 go state = do

346 go state = do

352− c <- getCommand (not psciMultiLineMode)

347+ c <- getCommand

353 case c of

348 case c of

354 Left err -> outputStrLn err >> go state

349 Left err -> outputStrLn err >> go state

355 Right Nothing -> go state

350 Right Nothing -> go state

351+ Right (Just PasteLines) -> do

352+ c' <- pasteMode

353+ case c' of

354+ Left err -> outputStrLn err >> go state

355+ Right c'' -> handleCommandWithInterrupts state c''

356 Right (Just QuitPSCi) -> do

357 outputStrLn quitMessage

358 liftIO $ shutdown state

359− Right (Just c') -> do

359+ Right (Just c') -> handleCommandWithInterrupts state c'

360+

361+ handleCommandWithInterrupts

362+ :: state

363+ -> Command

364+ -> InputT (StateT PSCiState (ReaderT PSCiConfig IO)) ()

365+ handleCommandWithInterrupts state cmd = do

360− handleInterrupt (outputStrLn "Interrupted.")

366+ handleInterrupt (outputStrLn "Interrupted.")

361− (withInterrupt (lift (handleCommand (liftIO . eval state) (liftIO (reload state)) c')))

367+ (withInterrupt (lift (handleCommand (liftIO . eval state) (liftIO (reload state)) cmd)))

362− go state

368+ go state

369+

363 putStrLn prologueMessage

370 putStrLn prologueMessage

364 setup >>= runner . go

371 setup >>= runner . go

purescript.cabal+28−3

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

1name: purescript

2−version: 0.10.1

2+version: 0.10.2

3cabal-version: >=1.8

4build-type: Simple

5license: BSD3

@@ -55,6 +55,8 @@ extra-source-files: examples/passing/*.purs

55 , examples/passing/TypeWithoutParens/*.purs

56 , examples/failing/*.purs

57 , examples/failing/1733/*.purs

58+ , examples/failing/2378/*.purs

59+ , examples/failing/2379/*.purs

58 , examples/failing/ConflictingExports/*.purs

60 , examples/failing/ConflictingExports/*.purs

59 , examples/failing/ConflictingImports/*.purs

61 , examples/failing/ConflictingImports/*.purs

60 , examples/failing/ConflictingImports2/*.purs

62 , examples/failing/ConflictingImports2/*.purs

@@ -120,9 +122,10 @@ library

120 fsnotify >= 0.2.1,

122 fsnotify >= 0.2.1,

121 Glob >= 0.7 && < 0.8,

123 Glob >= 0.7 && < 0.8,

122 haskeline >= 0.7.0.0,

124 haskeline >= 0.7.0.0,

123− http-client >= 0.4.30 && <0.6,

125+ http-client >= 0.4.30 && <0.5,

124 http-types -any,

126 http-types -any,

125 language-javascript == 0.6.*,

127 language-javascript == 0.6.*,

128+ lens == 4.*,

126 lifted-base >= 0.2.3 && < 0.2.4,

129 lifted-base >= 0.2.3 && < 0.2.4,

127 monad-control >= 1.0.0.0 && < 1.1,

130 monad-control >= 1.0.0.0 && < 1.1,

128 monad-logger >= 0.3 && < 0.4,

131 monad-logger >= 0.3 && < 0.4,

@@ -254,6 +257,7 @@ library

254 Language.PureScript.TypeChecker.Subsumption

257 Language.PureScript.TypeChecker.Subsumption

255 Language.PureScript.TypeChecker.Synonyms

258 Language.PureScript.TypeChecker.Synonyms

256 Language.PureScript.TypeChecker.Types

259 Language.PureScript.TypeChecker.Types

260+ Language.PureScript.TypeChecker.TypeSearch

257 Language.PureScript.TypeChecker.Unify

261 Language.PureScript.TypeChecker.Unify

258 Language.PureScript.TypeClassDictionaries

262 Language.PureScript.TypeClassDictionaries

259 Language.PureScript.Types

263 Language.PureScript.Types

@@ -347,6 +351,7 @@ executable psc

347 mtl -any,

351 mtl -any,

348 optparse-applicative >= 0.12.1,

352 optparse-applicative >= 0.12.1,

349 parsec -any,

353 parsec -any,

354+ text -any,

350 time -any,

355 time -any,

351 transformers -any,

356 transformers -any,

352 transformers-compat -any,

357 transformers-compat -any,

@@ -400,6 +405,7 @@ executable psc-docs

400 optparse-applicative >= 0.12.1,

405 optparse-applicative >= 0.12.1,

401 process -any,

406 process -any,

402 split -any,

407 split -any,

408+ text -any,

403 transformers -any,

409 transformers -any,

404 transformers-compat -any

410 transformers-compat -any

405 main-is: Main.hs

411 main-is: Main.hs

@@ -423,6 +429,24 @@ executable psc-publish

423 hs-source-dirs: psc-publish

429 hs-source-dirs: psc-publish

424 ghc-options: -Wall -O2

430 ghc-options: -Wall -O2

425

431

432+executable psc-package

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

434+ purescript -any,

435+ aeson -any,

436+ aeson-pretty -any,

437+ bytestring -any,

438+ containers -any,

439+ foldl -any,

440+ optparse-applicative -any,

441+ system-filepath -any,

442+ text -any,

443+ turtle -any

444+ main-is: Main.hs

445+ other-modules: Paths_purescript

446+ buildable: True

447+ hs-source-dirs: psc-package

448+ ghc-options: -Wall -O2

449+

426executable psc-hierarchy

450executable psc-hierarchy

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

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

428 purescript -any,

452 purescript -any,

@@ -432,7 +456,8 @@ executable psc-hierarchy

432 mtl -any,

456 mtl -any,

433 optparse-applicative >= 0.12.1,

457 optparse-applicative >= 0.12.1,

434 parsec -any,

458 parsec -any,

435− process -any

459+ process -any,

460+ text -any

436 main-is: Main.hs

461 main-is: Main.hs

437 other-modules: Paths_purescript

462 other-modules: Paths_purescript

438 buildable: True

463 buildable: True

src/Control/Monad/Supply.hs+2−1

@@ -7,6 +7,7 @@ module Control.Monad.Supply where

7

8import Prelude.Compat

9

10+import Control.Applicative

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

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

11import Control.Monad.Reader

12import Control.Monad.Reader

12import Control.Monad.State

13import Control.Monad.State

@@ -15,7 +16,7 @@ import Control.Monad.Writer

15import Data.Functor.Identity

16import Data.Functor.Identity

16

17

17newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a }

18newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a }

18− deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r)

19+ deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r, Alternative, MonadPlus)

19

20

20runSupplyT :: Integer -> SupplyT m a -> m (a, Integer)

21runSupplyT :: Integer -> SupplyT m a -> m (a, Integer)

21runSupplyT n = flip runStateT n . unSupplyT

22runSupplyT n = flip runStateT n . unSupplyT

src/Control/Monad/Supply/Class.hs+11−5

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

1-- |

2-- A class for monads supporting a supply of fresh names

3--

4+

5+{-# LANGUAGE DefaultSignatures #-}

6+

4module Control.Monad.Supply.Class where

7module Control.Monad.Supply.Class where

5

8

6import Prelude.Compat

9import Prelude.Compat

@@ -11,18 +14,21 @@ import Control.Monad.Writer

11

14

12class Monad m => MonadSupply m where

15class Monad m => MonadSupply m where

13 fresh :: m Integer

16 fresh :: m Integer

17+ peek :: m Integer

18+ default fresh :: MonadTrans t => t m Integer

19+ fresh = lift fresh

20+ default peek :: MonadTrans t => t m Integer

21+ peek = lift peek

14

22

15instance Monad m => MonadSupply (SupplyT m) where

23instance Monad m => MonadSupply (SupplyT m) where

16 fresh = SupplyT $ do

24 fresh = SupplyT $ do

17 n <- get

25 n <- get

18 put (n + 1)

26 put (n + 1)

19 return n

27 return n

28+ peek = SupplyT get

20

29

21−instance MonadSupply m => MonadSupply (StateT s m) where

30+instance MonadSupply m => MonadSupply (StateT s m)

22− fresh = lift fresh

23−

24−instance (Monoid w, MonadSupply m) => MonadSupply (WriterT w m) where

31+instance (Monoid w, MonadSupply m) => MonadSupply (WriterT w m)

25− fresh = lift fresh

26

32

27freshName :: MonadSupply m => m String

33freshName :: MonadSupply m => m String

28freshName = fmap (('$' :) . show) fresh

34freshName = fmap (('$' :) . show) fresh

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

@@ -29,6 +29,15 @@ import qualified Text.Parsec as P

29-- | A map of locally-bound names in scope.

30type Context = [(Ident, Type)]

31

32+-- | Holds the data necessary to do type directed search for typed holes

33+data TypeSearch

34+ = TSBefore Environment

35+ -- ^ An Environment captured for later consumption by type directed search

36+ | TSAfter [(Qualified Ident, Type)]

37+ -- ^ Results of applying type directed search to the previously captured

38+ -- Environment

39+ deriving Show

40+

32-- | A type of error messages

41-- | A type of error messages

33data SimpleErrorMessage

42data SimpleErrorMessage

34 = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)

43 = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)

@@ -74,6 +83,8 @@ data SimpleErrorMessage

74 | ConstrainedTypeUnified Type Type

83 | ConstrainedTypeUnified Type Type

75 | OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident]

84 | OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident]

76 | NoInstanceFound Constraint

85 | NoInstanceFound Constraint

86+ | AmbiguousTypeVariables Type Constraint

87+ | UnknownClass (Qualified (ProperName 'ClassName))

77 | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]

88 | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]

78 | CannotDerive (Qualified (ProperName 'ClassName)) [Type]

89 | CannotDerive (Qualified (ProperName 'ClassName)) [Type]

79 | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [Type]

90 | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [Type]

@@ -99,7 +110,7 @@ data SimpleErrorMessage

99 | ShadowedTypeVar String

110 | ShadowedTypeVar String

100 | UnusedTypeVar String

111 | UnusedTypeVar String

101 | WildcardInferredType Type Context

112 | WildcardInferredType Type Context

102− | HoleInferredType String Type Context

113+ | HoleInferredType String Type Context TypeSearch

103 | MissingTypeDeclaration Ident Type

114 | MissingTypeDeclaration Ident Type

104 | OverlappingPattern [[Binder]] Bool

115 | OverlappingPattern [[Binder]] Bool

105 | IncompleteExhaustivityCheck

116 | IncompleteExhaustivityCheck

@@ -123,7 +134,7 @@ data SimpleErrorMessage

123 | DeprecatedRequirePath

134 | DeprecatedRequirePath

124 | CannotGeneralizeRecursiveFunction Ident Type

135 | CannotGeneralizeRecursiveFunction Ident Type

125 | CannotDeriveNewtypeForData (ProperName 'TypeName)

136 | CannotDeriveNewtypeForData (ProperName 'TypeName)

126− | NonWildcardNewtypeInstance (ProperName 'TypeName)

137+ | ExpectedWildcard (ProperName 'TypeName)

127 deriving (Show)

138 deriving (Show)

128

139

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

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

@@ -250,6 +261,31 @@ instance Eq DeclarationRef where

250 r == (PositionedDeclarationRef _ _ r') = r == r'

261 r == (PositionedDeclarationRef _ _ r') = r == r'

251 _ == _ = False

262 _ == _ = False

252

263

264+-- enable sorting lists of explicitly imported refs when suggesting imports in linting, IDE, etc.

265+-- not an Ord because this implementation is not consistent with its Eq instance.

266+-- think of it as a notion of contextual, not inherent, ordering.

267+compDecRef :: DeclarationRef -> DeclarationRef -> Ordering

268+compDecRef (TypeRef name _) (TypeRef name' _) = compare name name'

269+compDecRef (TypeOpRef name) (TypeOpRef name') = compare name name'

270+compDecRef (ValueRef ident) (ValueRef ident') = compare ident ident'

271+compDecRef (ValueOpRef name) (ValueOpRef name') = compare name name'

272+compDecRef (TypeClassRef name) (TypeClassRef name') = compare name name'

273+compDecRef (TypeInstanceRef ident) (TypeInstanceRef ident') = compare ident ident'

274+compDecRef (ModuleRef name) (ModuleRef name') = compare name name'

275+compDecRef (ReExportRef name _) (ReExportRef name' _) = compare name name'

276+compDecRef (PositionedDeclarationRef _ _ ref) ref' = compDecRef ref ref'

277+compDecRef ref (PositionedDeclarationRef _ _ ref') = compDecRef ref ref'

278+compDecRef ref ref' = compare

279+ (orderOf ref) (orderOf ref')

280+ where

281+ orderOf :: DeclarationRef -> Int

282+ orderOf (TypeClassRef _) = 0

283+ orderOf (TypeOpRef _) = 1

284+ orderOf (TypeRef _ _) = 2

285+ orderOf (ValueRef _) = 3

286+ orderOf (ValueOpRef _) = 4

287+ orderOf _ = 5

288+

253getTypeRef :: DeclarationRef -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName])

289getTypeRef :: DeclarationRef -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName])

254getTypeRef (TypeRef name dctors) = Just (name, dctors)

290getTypeRef (TypeRef name dctors) = Just (name, dctors)

255getTypeRef (PositionedDeclarationRef _ _ r) = getTypeRef r

291getTypeRef (PositionedDeclarationRef _ _ r) = getTypeRef r

src/Language/PureScript/AST/Traversals.hs+15−2

@@ -474,7 +474,8 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)

474 in foldMap (f'' s') ds

475 f' s (ValueDeclaration name _ bs (Right val)) =

476 let s' = S.insert name s

477+ s'' = S.union s' (S.fromList (concatMap binderNames bs))

477− in foldMap (h'' s') bs <> g'' s' val

478+ in foldMap (h'' s') bs <> g'' s'' val

478 f' s (ValueDeclaration name _ bs (Left gs)) =

479 f' s (ValueDeclaration name _ bs (Left gs)) =

479 let s' = S.insert name s

480 let s' = S.insert name s

480 s'' = S.union s' (S.fromList (concatMap binderNames bs))

481 s'' = S.union s' (S.fromList (concatMap binderNames bs))

@@ -551,7 +552,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)

551 j' s (DoNotationValue v) = (s, g'' s v)

552 j' s (DoNotationValue v) = (s, g'' s v)

552 j' s (DoNotationBind b v) =

553 j' s (DoNotationBind b v) =

553 let s' = S.union (S.fromList (binderNames b)) s

554 let s' = S.union (S.fromList (binderNames b)) s

554− in (s', h'' s b <> g'' s' v)

555+ in (s', h'' s b <> g'' s v)

555 j' s (DoNotationLet ds) =

556 j' s (DoNotationLet ds) =

556 let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))

557 let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))

557 in (s', foldMap (f'' s') ds)

558 in (s', foldMap (f'' s') ds)

@@ -586,3 +587,15 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con

586 forValues (DeferredDictionary _ tys) = mconcat (map f tys)

587 forValues (DeferredDictionary _ tys) = mconcat (map f tys)

587 forValues (TypedValue _ _ ty) = f ty

588 forValues (TypedValue _ _ ty) = f ty

588 forValues _ = mempty

589 forValues _ = mempty

590+

591+-- |

592+-- Map a function over type annotations appearing inside a value

593+--

594+overTypes :: (Type -> Type) -> Expr -> Expr

595+overTypes f = let (_, f', _) = everywhereOnValues id g id in f'

596+ where

597+ g :: Expr -> Expr

598+ g (TypedValue checkTy val t) = TypedValue checkTy val (f t)

599+ g (TypeClassDictionary c sco hints) = TypeClassDictionary (mapConstraintArgs (map f) c) sco hints

600+ g other = other

601+

src/Language/PureScript/CodeGen/JS.hs+8−8

@@ -244,23 +244,23 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

244 ret <- valueToJs val

245 return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (ds' ++ [JSReturn Nothing ret]))) []

246 valueToJs' (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =

247− return $ JSVariableIntroduction Nothing ctor (Just $

247+ return $ JSVariableIntroduction Nothing (properToJs ctor) (Just $

248 JSObjectLiteral Nothing [("create",

249 JSFunction Nothing Nothing ["value"]

250 (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))])

251 valueToJs' (Constructor _ _ (ProperName ctor) []) =

252− return $ iife ctor [ JSFunction Nothing (Just ctor) [] (JSBlock Nothing [])

252+ return $ iife (properToJs ctor) [ JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing [])

253− , JSAssignment Nothing (JSAccessor Nothing "value" (JSVar Nothing ctor))

253+ , JSAssignment Nothing (JSAccessor Nothing "value" (JSVar Nothing (properToJs ctor)))

254− (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing ctor) []) ]

254+ (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) []) ]

255 valueToJs' (Constructor _ _ (ProperName ctor) fields) =

256 let constructor =

257 let body = [ JSAssignment Nothing (JSAccessor Nothing (identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]

258− in JSFunction Nothing (Just ctor) (identToJs `map` fields) (JSBlock Nothing body)

258+ in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body)

259 createFn =

260− let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing ctor) (var `map` fields)

260+ let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields)

261 in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields

262− in return $ iife ctor [ constructor

262+ in return $ iife (properToJs ctor) [ constructor

263− , JSAssignment Nothing (JSAccessor Nothing "create" (JSVar Nothing ctor)) createFn

263+ , JSAssignment Nothing (JSAccessor Nothing "create" (JSVar Nothing (properToJs ctor))) createFn

264 ]

265

266 iife :: String -> [JS] -> JS

src/Language/PureScript/CodeGen/JS/Common.hs+5−2

@@ -26,10 +26,13 @@ moduleNameToJs (ModuleName pns) =

26-- * Symbols are prefixed with '$' followed by a symbol name or their ordinal value.

27--

28identToJs :: Ident -> String

29−identToJs (Ident name)

29+identToJs (Ident name) = properToJs name

30+identToJs (GenIdent _ _) = internalError "GenIdent in identToJs"

31+

32+properToJs :: String -> String

33+properToJs name

30 | nameIsJsReserved name || nameIsJsBuiltIn name = "$$" ++ name

34 | nameIsJsReserved name || nameIsJsBuiltIn name = "$$" ++ name

31 | otherwise = concatMap identCharToString name

35 | otherwise = concatMap identCharToString name

32−identToJs (GenIdent _ _) = internalError "GenIdent in identToJs"

33

36

34-- |

37-- |

35-- Test if a string is a valid JS identifier without escaping.

38-- Test if a string is a valid JS identifier without escaping.

src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs+21−15

@@ -99,15 +99,6 @@ inlineCommonValues = everywhereOnJS convert

99 fnSubtract = (C.dataRing, C.sub)

100 intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0))

101

102−inlineNonClassFunction :: (String, String) -> (JS -> JS -> JS) -> JS -> JS

103−inlineNonClassFunction (m, op) f = everywhereOnJS convert

104− where

105− convert :: JS -> JS

106− convert (JSApp _ (JSApp _ op' [x]) [y]) | isOp op' = f x y

107− convert other = other

108− isOp (JSAccessor _ op' (JSVar _ m')) = m == m' && op == op'

109− isOp _ = False

110−

111inlineCommonOperators :: JS -> JS

102inlineCommonOperators :: JS -> JS

112inlineCommonOperators = applyAll $

103inlineCommonOperators = applyAll $

113 [ binary semiringNumber opAdd Add

104 [ binary semiringNumber opAdd Add

@@ -159,17 +150,17 @@ inlineCommonOperators = applyAll $

159 , binary heytingAlgebraBoolean opDisj Or

150 , binary heytingAlgebraBoolean opDisj Or

160 , unary heytingAlgebraBoolean opNot Not

151 , unary heytingAlgebraBoolean opNot Not

161

152

162− , binary' C.dataIntBits (C..|.) BitwiseOr

153+ , binary' C.dataIntBits C.or BitwiseOr

163− , binary' C.dataIntBits (C..&.) BitwiseAnd

154+ , binary' C.dataIntBits C.and BitwiseAnd

164− , binary' C.dataIntBits (C..^.) BitwiseXor

155+ , binary' C.dataIntBits C.xor BitwiseXor

165 , binary' C.dataIntBits C.shl ShiftLeft

156 , binary' C.dataIntBits C.shl ShiftLeft

166 , binary' C.dataIntBits C.shr ShiftRight

157 , binary' C.dataIntBits C.shr ShiftRight

167 , binary' C.dataIntBits C.zshr ZeroFillShiftRight

158 , binary' C.dataIntBits C.zshr ZeroFillShiftRight

168 , unary' C.dataIntBits C.complement BitwiseNot

159 , unary' C.dataIntBits C.complement BitwiseNot

169

160

170− , inlineNonClassFunction (C.dataFunction, C.apply) $ \f x -> JSApp Nothing f [x]

161+ , inlineNonClassFunction (isModFn (C.dataFunction, C.apply)) $ \f x -> JSApp Nothing f [x]

171− , inlineNonClassFunction (C.dataFunction, C.applyFlipped) $ \x f -> JSApp Nothing f [x]

162+ , inlineNonClassFunction (isModFn (C.dataFunction, C.applyFlipped)) $ \x f -> JSApp Nothing f [x]

172− , inlineNonClassFunction (C.dataArrayUnsafe, C.unsafeIndex) $ flip (JSIndexer Nothing)

163+ , inlineNonClassFunction (isModFnWithDict (C.dataArray, C.unsafeIndex)) $ flip (JSIndexer Nothing)

173 ] ++

164 ] ++

174 [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]

165 [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]

175 where

166 where

@@ -233,6 +224,21 @@ inlineCommonOperators = applyAll $

233 go m acc (JSApp _ lhs [arg]) = go (m - 1) (arg : acc) lhs

224 go m acc (JSApp _ lhs [arg]) = go (m - 1) (arg : acc) lhs

234 go _ _ _ = Nothing

225 go _ _ _ = Nothing

235

226

227+ inlineNonClassFunction :: (JS -> Bool) -> (JS -> JS -> JS) -> JS -> JS

228+ inlineNonClassFunction p f = everywhereOnJS convert

229+ where

230+ convert :: JS -> JS

231+ convert (JSApp _ (JSApp _ op' [x]) [y]) | p op' = f x y

232+ convert other = other

233+

234+ isModFn :: (String, String) -> JS -> Bool

235+ isModFn (m, op) (JSAccessor _ op' (JSVar _ m')) = m == m' && op == op'

236+ isModFn _ _ = False

237+

238+ isModFnWithDict :: (String, String) -> JS -> Bool

239+ isModFnWithDict (m, op) (JSApp _ (JSAccessor _ op' (JSVar _ m')) [(JSVar _ _)]) = m == m' && op == op'

240+ isModFnWithDict _ _ = False

241+

236-- (f <<< g $ x) = f (g x)

242-- (f <<< g $ x) = f (g x)

237-- (f <<< g) = \x -> f (g x)

243-- (f <<< g) = \x -> f (g x)

238inlineFnComposition :: (MonadSupply m) => JS -> m JS

244inlineFnComposition :: (MonadSupply m) => JS -> m JS

src/Language/PureScript/Constants.hs+8−8

@@ -118,14 +118,14 @@ disj = "disj"

118unsafeIndex :: String

119unsafeIndex = "unsafeIndex"

120

121−(.|.) :: String

121+or :: String

122−(.|.) = ".|."

122+or = "or"

123

124−(.&.) :: String

124+and :: String

125−(.&.) = ".&."

125+and = "and"

126

127−(.^.) :: String

127+xor :: String

128−(.^.) = ".^."

128+xor = "xor"

129

130(<<<) :: String

131(<<<) = "<<<"

@@ -346,8 +346,8 @@ prim = "Prim"

346prelude :: String

347prelude = "Prelude"

348

349−dataArrayUnsafe :: String

349+dataArray :: String

350−dataArrayUnsafe = "Data_Array_Unsafe"

350+dataArray = "Data_Array"

351

352eff :: String

353eff = "Control_Monad_Eff"

src/Language/PureScript/Docs/ParseAndBookmark.hs+6−7

@@ -9,13 +9,12 @@ import Control.Monad.Error.Class (MonadError(..))

9import Control.Monad.IO.Class (MonadIO(..))

10

11import qualified Data.Map as M

12+import Data.Text (Text)

12

13

13import Language.PureScript.Docs.Convert (collectBookmarks)

14import Language.PureScript.Docs.Convert (collectBookmarks)

14import Language.PureScript.Docs.Types

15import Language.PureScript.Docs.Types

15import qualified Language.PureScript as P

16import qualified Language.PureScript as P

16−

17−import System.IO.UTF8 (readUTF8File)

17+import System.IO.UTF8 (readUTF8FileT)

18−

19import Web.Bower.PackageMeta (PackageName)

18import Web.Bower.PackageMeta (PackageName)

20

19

21-- |

20-- |

@@ -45,7 +44,7 @@ parseAndBookmark inputFiles depsFiles = do

45

44

46parseFiles ::

45parseFiles ::

47 (MonadError P.MultipleErrors m) =>

46 (MonadError P.MultipleErrors m) =>

48− [(FileInfo, FilePath)]

47+ [(FileInfo, Text)]

49 -> m [(FileInfo, P.Module)]

48 -> m [(FileInfo, P.Module)]

50parseFiles =

49parseFiles =

51 throwLeft . P.parseModulesFromFiles fileInfoToString

50 throwLeft . P.parseModulesFromFiles fileInfoToString

@@ -77,10 +76,10 @@ fileInfoToString :: FileInfo -> FilePath

77fileInfoToString (Local fn) = fn

76fileInfoToString (Local fn) = fn

78fileInfoToString (FromDep _ fn) = fn

77fileInfoToString (FromDep _ fn) = fn

79

78

80−parseFile :: FilePath -> IO (FilePath, String)

79+parseFile :: FilePath -> IO (FilePath, Text)

81−parseFile input' = (,) input' <$> readUTF8File input'

80+parseFile input' = (,) input' <$> readUTF8FileT input'

82

81

83−parseAs :: (MonadIO m) => (FilePath -> a) -> FilePath -> m (a, String)

82+parseAs :: (MonadIO m) => (FilePath -> a) -> FilePath -> m (a, Text)

84parseAs g = fmap (first g) . liftIO . parseFile

83parseAs g = fmap (first g) . liftIO . parseFile

85

84

86getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName

85getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName

src/Language/PureScript/Environment.hs+5−4

@@ -236,8 +236,8 @@ function t1 = TypeApp (TypeApp tyFunction t1)

236

237-- |

238-- The primitive types in the external javascript environment with their

239−-- associated kinds. There is also a pseudo `Partial` type that corresponds to

239+-- associated kinds. There are also pseudo `Fail` and `Partial` types

240−-- the class with the same name.

240+-- that correspond to the classes with the same names.

241--

242primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)

243primTypes =

@@ -257,8 +257,9 @@ primTypes =

257 ]

258

259-- |

260−-- The primitive class map. This just contains to `Partial` class, used as a

260+-- The primitive class map. This just contains the `Fail` and `Partial`

261−-- kind of magic constraint for partial functions.

261+-- classes. `Partial` is used as a kind of magic constraint for partial

262+-- functions. `Fail` is used for user-defined type errors.

262--

263--

263primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData

264primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData

264primClasses =

265primClasses =

src/Language/PureScript/Errors.hs+59−21

@@ -40,6 +40,7 @@ import qualified System.Console.ANSI as ANSI

40import qualified Text.Parsec as P

41import qualified Text.Parsec.Error as PE

42import qualified Text.PrettyPrint.Boxes as Box

43+import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers

43import Text.Parsec.Error (Message(..))

44import Text.Parsec.Error (Message(..))

44

45

45newtype ErrorSuggestion = ErrorSuggestion String

46newtype ErrorSuggestion = ErrorSuggestion String

@@ -117,6 +118,8 @@ errorCode em = case unwrapErrorMessage em of

117 ConstrainedTypeUnified{} -> "ConstrainedTypeUnified"

118 ConstrainedTypeUnified{} -> "ConstrainedTypeUnified"

118 OverlappingInstances{} -> "OverlappingInstances"

119 OverlappingInstances{} -> "OverlappingInstances"

119 NoInstanceFound{} -> "NoInstanceFound"

120 NoInstanceFound{} -> "NoInstanceFound"

121+ AmbiguousTypeVariables{} -> "AmbiguousTypeVariables"

122+ UnknownClass{} -> "UnknownClass"

120 PossiblyInfiniteInstance{} -> "PossiblyInfiniteInstance"

123 PossiblyInfiniteInstance{} -> "PossiblyInfiniteInstance"

121 CannotDerive{} -> "CannotDerive"

124 CannotDerive{} -> "CannotDerive"

122 InvalidNewtypeInstance{} -> "InvalidNewtypeInstance"

125 InvalidNewtypeInstance{} -> "InvalidNewtypeInstance"

@@ -166,7 +169,7 @@ errorCode em = case unwrapErrorMessage em of

166 DeprecatedRequirePath{} -> "DeprecatedRequirePath"

169 DeprecatedRequirePath{} -> "DeprecatedRequirePath"

167 CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction"

170 CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction"

168 CannotDeriveNewtypeForData{} -> "CannotDeriveNewtypeForData"

171 CannotDeriveNewtypeForData{} -> "CannotDeriveNewtypeForData"

169− NonWildcardNewtypeInstance{} -> "NonWildcardNewtypeInstance"

172+ ExpectedWildcard{} -> "ExpectedWildcard"

170

173

171-- |

174-- |

172-- A stack trace for an error

175-- A stack trace for an error

@@ -259,6 +262,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse

259 gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t

262 gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t

260 gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t

263 gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t

261 gSimple (NoInstanceFound con) = NoInstanceFound <$> overConstraintArgs (traverse f) con

264 gSimple (NoInstanceFound con) = NoInstanceFound <$> overConstraintArgs (traverse f) con

265+ gSimple (AmbiguousTypeVariables t con) = AmbiguousTypeVariables <$> (f t) <*> pure con

262 gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts

266 gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts

263 gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts

267 gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts

264 gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts

268 gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts

@@ -266,7 +270,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse

266 gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k

270 gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k

267 gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts

271 gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts

268 gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx

272 gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx

269− gSimple (HoleInferredType name ty ctx) = HoleInferredType name <$> f ty <*> traverse (sndM f) ctx

273+ gSimple (HoleInferredType name ty ctx env) = HoleInferredType name <$> f ty <*> traverse (sndM f) ctx <*> gTypeSearch env

270 gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty

274 gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty

271 gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty

275 gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty

272 gSimple other = pure other

276 gSimple other = pure other

@@ -280,6 +284,9 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse

280 gHint (ErrorSolvingConstraint con) = ErrorSolvingConstraint <$> overConstraintArgs (traverse f) con

284 gHint (ErrorSolvingConstraint con) = ErrorSolvingConstraint <$> overConstraintArgs (traverse f) con

281 gHint other = pure other

285 gHint other = pure other

282

286

287+ gTypeSearch (TSBefore env) = pure (TSBefore env)

288+ gTypeSearch (TSAfter result) = TSAfter <$> traverse (traverse f) result

289+

283wikiUri :: ErrorMessage -> String

290wikiUri :: ErrorMessage -> String

284wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e

291wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e

285

292

@@ -287,19 +294,19 @@ wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ error

287-- WildcardInferredType - source span not small enough

294-- WildcardInferredType - source span not small enough

288-- DuplicateSelectiveImport - would require 2 ranges to remove and 1 insert

295-- DuplicateSelectiveImport - would require 2 ranges to remove and 1 insert

289errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion

296errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion

290−errorSuggestion err = case err of

297+errorSuggestion err =

298+ case err of

291− UnusedImport{} -> emptySuggestion

299+ UnusedImport{} -> emptySuggestion

292− DuplicateImport{} -> emptySuggestion

300+ DuplicateImport{} -> emptySuggestion

293− UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual

301+ UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual

294− UnusedDctorImport mn _ qual refs -> suggest $ importSuggestion mn refs qual

302+ UnusedDctorImport mn _ qual refs -> suggest $ importSuggestion mn refs qual

295− UnusedDctorExplicitImport mn _ _ qual refs -> suggest $ importSuggestion mn refs qual

303+ UnusedDctorExplicitImport mn _ _ qual refs -> suggest $ importSuggestion mn refs qual

296− ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing

304+ ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing

297− ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)

305+ ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)

298− HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing

306+ HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing

299− MissingTypeDeclaration ident ty -> suggest $ showIdent ident ++ " :: " ++ prettyPrintType ty

307+ MissingTypeDeclaration ident ty -> suggest $ showIdent ident ++ " :: " ++ prettyPrintSuggestedType ty

300− WildcardInferredType ty _ -> suggest $ prettyPrintType ty

308+ WildcardInferredType ty _ -> suggest $ prettyPrintSuggestedType ty

301− _ -> Nothing

309+ _ -> Nothing

302−

303 where

310 where

304 emptySuggestion = Just $ ErrorSuggestion ""

311 emptySuggestion = Just $ ErrorSuggestion ""

305 suggest = Just . ErrorSuggestion

312 suggest = Just . ErrorSuggestion

@@ -595,6 +602,11 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

595 , line "They may be disallowed completely in a future version of the compiler."

602 , line "They may be disallowed completely in a future version of the compiler."

596 ]

603 ]

597 renderSimpleErrorMessage OverlappingInstances{} = internalError "OverlappingInstances: empty instance list"

604 renderSimpleErrorMessage OverlappingInstances{} = internalError "OverlappingInstances: empty instance list"

605+ renderSimpleErrorMessage (UnknownClass nm) =

606+ paras [ line "No type class instance was found for class"

607+ , markCodeBox $ indent $ line (showQualified runProperName nm)

608+ , line "because the class was not in scope. Perhaps it was not exported."

609+ ]

598 renderSimpleErrorMessage (NoInstanceFound (Constraint C.Fail [ ty ] _)) | Just box <- toTypelevelString ty =

610 renderSimpleErrorMessage (NoInstanceFound (Constraint C.Fail [ ty ] _)) | Just box <- toTypelevelString ty =

599 paras [ line "A custom type error occurred while solving type class constraints:"

611 paras [ line "A custom type error occurred while solving type class constraints:"

600 , indent box

612 , indent box

@@ -626,6 +638,11 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

626 where

638 where

627 go TUnknown{} = True

639 go TUnknown{} = True

628 go _ = False

640 go _ = False

641+ renderSimpleErrorMessage (AmbiguousTypeVariables t _) =

642+ paras [ line "The inferred type"

643+ , indent $ line $ markCode $ prettyPrintType t

644+ , line "has type variables which are not mentioned in the body of the type. Consider adding a type annotation."

645+ ]

629 renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =

646 renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =

630 paras [ line "Type class instance for"

647 paras [ line "Type class instance for"

631 , markCodeBox $ indent $ Box.hsep 1 Box.left

648 , markCodeBox $ indent $ Box.hsep 1 Box.left

@@ -733,10 +750,31 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

733 paras $ [ line "Wildcard type definition has the inferred type "

750 paras $ [ line "Wildcard type definition has the inferred type "

734 , markCodeBox $ indent $ typeAsBox ty

751 , markCodeBox $ indent $ typeAsBox ty

735 ] ++ renderContext ctx

752 ] ++ renderContext ctx

736− renderSimpleErrorMessage (HoleInferredType name ty ctx) =

753+ renderSimpleErrorMessage (HoleInferredType name ty ctx ts) =

754+ let

755+ maxTSResults = 15

756+ tsResult = case ts of

757+ (TSAfter idents) | not (null idents) ->

758+ let

759+ formatTS (names, types) =

760+ let

761+ idBoxes = Box.text . showQualified runIdent <$> names

762+ tyBoxes = (\t -> BoxHelpers.indented

763+ (Box.text ":: " Box.<> typeAsBox t)) <$> types

764+ longestId = maximum (map Box.cols idBoxes)

765+ in

766+ Box.vcat Box.top $

767+ zipWith (Box.<>)

768+ (Box.alignHoriz Box.left longestId <$> idBoxes)

769+ tyBoxes

770+ in [ line "You could substitute the hole with one of these values:"

771+ , markCodeBox (indent (formatTS (unzip (take maxTSResults idents))))

772+ ]

773+ _ -> []

774+ in

737− paras $ [ line $ "Hole '" ++ markCode name ++ "' has the inferred type "

775+ paras $ [ line $ "Hole '" ++ markCode name ++ "' has the inferred type "

738− , markCodeBox $ indent $ typeAsBox ty

776+ , markCodeBox (indent (typeAsBox ty))

739− ] ++ renderContext ctx

777+ ] ++ tsResult ++ renderContext ctx

740 renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =

778 renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =

741 paras [ line $ "No type declaration was provided for the top-level declaration of " ++ markCode (showIdent ident) ++ "."

779 paras [ line $ "No type declaration was provided for the top-level declaration of " ++ markCode (showIdent ident) ++ "."

742 , line "It is good practice to provide type declarations as a form of documentation."

780 , line "It is good practice to provide type declarations as a form of documentation."

@@ -834,8 +872,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

834 paras [ line $ "Cannot derive an instance of the " ++ markCode "Newtype" ++ " class for non-newtype " ++ markCode (runProperName tyName) ++ "."

872 paras [ line $ "Cannot derive an instance of the " ++ markCode "Newtype" ++ " class for non-newtype " ++ markCode (runProperName tyName) ++ "."

835 ]

873 ]

836

874

837− renderSimpleErrorMessage (NonWildcardNewtypeInstance tyName) =

875+ renderSimpleErrorMessage (ExpectedWildcard tyName) =

838− paras [ line $ "A type wildcard (_) should be used for the inner type when deriving the " ++ markCode "Newtype" ++ " instance for " ++ markCode (runProperName tyName) ++ "."

876+ paras [ line $ "Expected a type wildcard (_) when deriving an instance for " ++ markCode (runProperName tyName) ++ "."

839 ]

877 ]

840

878

841 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

879 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

src/Language/PureScript/Ide/CaseSplit.hs+6−6

@@ -12,7 +12,7 @@

12-- Casesplitting and adding function clauses

13-----------------------------------------------------------------------------

14

15−{-# LANGUAGE OverloadedStrings #-}

15+{-# LANGUAGE OverloadedStrings #-}

16

17module Language.PureScript.Ide.CaseSplit

18 ( WildcardAnnotations()

@@ -23,10 +23,10 @@ module Language.PureScript.Ide.CaseSplit

23 , caseSplit

24 ) where

25

26−import Protolude hiding (Constructor)

26+import Protolude hiding (Constructor)

27

28−import qualified Data.Text as T

28+import qualified Data.Text as T

29−import qualified Language.PureScript as P

29+import qualified Language.PureScript as P

30

31import Language.PureScript.Externs

32import Language.PureScript.Ide.Error

@@ -34,8 +34,8 @@ import Language.PureScript.Ide.State

34import Language.PureScript.Ide.Types

35import Language.PureScript.Ide.Util

36

37−import Text.Parsec as Parsec

37+import Text.Parsec as Parsec

38−import qualified Text.PrettyPrint.Boxes as Box

38+import qualified Text.PrettyPrint.Boxes as Box

39

40type Constructor = (P.ProperName 'P.ConstructorName, [P.Type])

41

src/Language/PureScript/Ide/Command.hs+2−1

@@ -12,7 +12,8 @@

12-- Datatypes for the commands psc-ide accepts

13-----------------------------------------------------------------------------

14

15−{-# LANGUAGE OverloadedStrings #-}

15+{-# LANGUAGE OverloadedStrings #-}

16+

16

17

17module Language.PureScript.Ide.Command where

18module Language.PureScript.Ide.Command where

18

19

src/Language/PureScript/Ide/Conversions.hs+9−3

@@ -14,16 +14,23 @@

14

15module Language.PureScript.Ide.Conversions where

16

17−import Protolude

17+import Control.Lens.Iso

18−import Data.Text (unwords, lines, strip)

18+import Data.Text (lines, strip, unwords)

19import qualified Language.PureScript as P

20+import Protolude

20

21

21runProperNameT :: P.ProperName a -> Text

22runProperNameT :: P.ProperName a -> Text

22runProperNameT = toS . P.runProperName

23runProperNameT = toS . P.runProperName

23

24

25+properNameT :: Iso' (P.ProperName a) Text

26+properNameT = iso (toS . P.runProperName) (P.ProperName . toS)

27+

24runIdentT :: P.Ident -> Text

28runIdentT :: P.Ident -> Text

25runIdentT = toS . P.runIdent

29runIdentT = toS . P.runIdent

26

30

31+identT :: Iso' P.Ident Text

32+identT = iso (toS . P.runIdent) (P.Ident . toS)

33+

27runOpNameT :: P.OpName a -> Text

34runOpNameT :: P.OpName a -> Text

28runOpNameT = toS . P.runOpName

35runOpNameT = toS . P.runOpName

29

36

@@ -32,4 +39,3 @@ runModuleNameT = toS . P.runModuleName

32

39

33prettyTypeT :: P.Type -> Text

40prettyTypeT :: P.Type -> Text

34prettyTypeT = unwords . map strip . lines . toS . P.prettyPrintType

41prettyTypeT = unwords . map strip . lines . toS . P.prettyPrintType

35−

src/Language/PureScript/Ide/Error.hs+3−3

@@ -17,11 +17,11 @@ module Language.PureScript.Ide.Error

17 ( PscIdeError(..)

18 ) where

19

20−import Protolude

21import Data.Aeson

20import Data.Aeson

22import Language.PureScript.Errors.JSON

21import Language.PureScript.Errors.JSON

23−import Language.PureScript.Ide.Types (ModuleIdent)

22+import Language.PureScript.Ide.Types (ModuleIdent)

23+import Protolude

24−import qualified Text.Parsec.Error as P

24+import qualified Text.Parsec.Error as P

25

26data PscIdeError

27 = GeneralError Text

src/Language/PureScript/Ide/Externs.hs+29−28

@@ -14,7 +14,6 @@

14

15{-# LANGUAGE OverloadedStrings #-}

16{-# LANGUAGE RecordWildCards #-}

17−{-# LANGUAGE FlexibleContexts #-}

18

17

19module Language.PureScript.Ide.Externs

18module Language.PureScript.Ide.Externs

20 ( readExternFile

19 ( readExternFile

@@ -24,10 +23,11 @@ module Language.PureScript.Ide.Externs

24

23

25import Protolude

24import Protolude

26

25

26+import Control.Lens ((^.))

27import Data.Aeson (decodeStrict)

28+import qualified Data.ByteString as BS

28import Data.List (nub)

29import Data.List (nub)

29import qualified Data.Map as Map

30import qualified Data.Map as Map

30−import qualified Data.ByteString as BS

31import Language.PureScript.Ide.Error (PscIdeError (..))

32import Language.PureScript.Ide.Types

33import Language.PureScript.Ide.Util

@@ -58,14 +58,14 @@ convertExterns ef =

58 cleanDeclarations = nub $ appEndo typeClassFilter declarations

59

60removeTypeDeclarationsForClass :: IdeDeclaration -> Endo [IdeDeclaration]

61−removeTypeDeclarationsForClass (IdeTypeClass n) = Endo (filter notDuplicate)

61+removeTypeDeclarationsForClass (IdeDeclTypeClass n) = Endo (filter notDuplicate)

62− where notDuplicate (IdeType n' _) = runProperNameT n /= runProperNameT n'

62+ where notDuplicate (IdeDeclType t) = n ^. properNameT /= t ^. ideTypeName . properNameT

63− notDuplicate (IdeTypeSynonym n' _) = runProperNameT n /= runProperNameT n'

63+ notDuplicate (IdeDeclTypeSynonym s) = n ^. properNameT /= s ^. ideSynonymName . properNameT

64 notDuplicate _ = True

65removeTypeDeclarationsForClass _ = mempty

66

67isTypeClassDeclaration :: IdeDeclaration -> Bool

68−isTypeClassDeclaration IdeTypeClass{} = True

68+isTypeClassDeclaration IdeDeclTypeClass{} = True

69isTypeClassDeclaration _ = False

70

71convertExport :: P.DeclarationRef -> Maybe (P.ModuleName, P.DeclarationRef)

@@ -73,19 +73,20 @@ convertExport (P.ReExportRef m r) = Just (m, r)

73convertExport _ = Nothing

74

75convertDecl :: P.ExternsDeclaration -> Maybe IdeDeclaration

76+convertDecl P.EDType{..} = Just $ IdeDeclType $

76−convertDecl P.EDType{..} = Just (IdeType edTypeName edTypeKind)

77+ IdeType edTypeName edTypeKind

77−convertDecl P.EDTypeSynonym{..} =

78+convertDecl P.EDTypeSynonym{..} = Just $ IdeDeclTypeSynonym

78− Just (IdeTypeSynonym edTypeSynonymName edTypeSynonymType)

79+ (IdeSynonym edTypeSynonymName edTypeSynonymType)

79−convertDecl P.EDDataConstructor{..} = Just $

80+convertDecl P.EDDataConstructor{..} = Just $ IdeDeclDataConstructor $

80 IdeDataConstructor edDataCtorName edDataCtorTypeCtor edDataCtorType

81 IdeDataConstructor edDataCtorName edDataCtorTypeCtor edDataCtorType

81−convertDecl P.EDValue{..} = Just $

82+convertDecl P.EDValue{..} = Just $ IdeDeclValue $

82 IdeValue edValueName edValueType

83 IdeValue edValueName edValueType

83−convertDecl P.EDClass{..} = Just (IdeTypeClass edClassName)

84+convertDecl P.EDClass{..} = Just (IdeDeclTypeClass edClassName)

84convertDecl P.EDInstance{} = Nothing

85convertDecl P.EDInstance{} = Nothing

85

86

86convertOperator :: P.ExternsFixity -> IdeDeclaration

87convertOperator :: P.ExternsFixity -> IdeDeclaration

87convertOperator P.ExternsFixity{..} =

88convertOperator P.ExternsFixity{..} =

88− IdeValueOperator

89+ IdeDeclValueOperator $ IdeValueOperator

89 efOperator

90 efOperator

90 efAlias

91 efAlias

91 efPrecedence

92 efPrecedence

@@ -94,7 +95,7 @@ convertOperator P.ExternsFixity{..} =

94

95

95convertTypeOperator :: P.ExternsTypeFixity -> IdeDeclaration

96convertTypeOperator :: P.ExternsTypeFixity -> IdeDeclaration

96convertTypeOperator P.ExternsTypeFixity{..} =

97convertTypeOperator P.ExternsTypeFixity{..} =

97− IdeTypeOperator

98+ IdeDeclTypeOperator $ IdeTypeOperator

98 efTypeOperator

99 efTypeOperator

99 efTypeAlias

100 efTypeAlias

100 efTypePrecedence

101 efTypePrecedence

@@ -110,20 +111,20 @@ annotateModule (defs, types) (moduleName, decls) =

110 where

111 where

111 convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn

112 convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn

112 convertDeclaration (IdeDeclarationAnn ann d) = case d of

113 convertDeclaration (IdeDeclarationAnn ann d) = case d of

113− IdeValue i t ->

114+ IdeDeclValue v ->

114− annotateFunction i (IdeValue i t)

115+ annotateFunction (v ^. ideValueIdent) (IdeDeclValue v)

115− IdeType i k ->

116+ IdeDeclType t ->

116− annotateType (runProperNameT i) (IdeType i k)

117+ annotateType (t ^. ideTypeName . properNameT) (IdeDeclType t)

117− IdeTypeSynonym i t ->

118+ IdeDeclTypeSynonym s ->

118− annotateType (runProperNameT i) (IdeTypeSynonym i t)

119+ annotateType (s ^. ideSynonymName . properNameT) (IdeDeclTypeSynonym s)

119− IdeDataConstructor i tn t ->

120+ IdeDeclDataConstructor dtor ->

120− annotateValue (runProperNameT i) (IdeDataConstructor i tn t)

121+ annotateValue (dtor ^. ideDtorName . properNameT) (IdeDeclDataConstructor dtor)

121− IdeTypeClass i ->

122+ IdeDeclTypeClass i ->

122− annotateType (runProperNameT i) (IdeTypeClass i)

123+ annotateType (runProperNameT i) (IdeDeclTypeClass i)

123− IdeValueOperator n i p a t ->

124+ IdeDeclValueOperator op ->

124− annotateValue (valueOperatorAliasT i) (IdeValueOperator n i p a t)

125+ annotateValue (op ^. ideValueOpAlias & valueOperatorAliasT) (IdeDeclValueOperator op)

125− IdeTypeOperator n i p a k ->

126+ IdeDeclTypeOperator op ->

126− annotateType (typeOperatorAliasT i) (IdeTypeOperator n i p a k)

127+ annotateType (op ^. ideTypeOpAlias & typeOperatorAliasT) (IdeDeclTypeOperator op)

127 where

128 where

128 annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (Left (runIdentT x)) defs

129 annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (Left (runIdentT x)) defs

129 , annTypeAnnotation = Map.lookup x types

130 , annTypeAnnotation = Map.lookup x types

src/Language/PureScript/Ide/Filter.hs+3−4

@@ -23,13 +23,13 @@ module Language.PureScript.Ide.Filter

23 , applyFilters

24 ) where

25

26−import Protolude hiding (isPrefixOf)

26+import Protolude hiding (isPrefixOf)

27

28import Data.Aeson

29import Data.Text (isPrefixOf)

30+import qualified Language.PureScript as P

30import Language.PureScript.Ide.Types

31import Language.PureScript.Ide.Types

31import Language.PureScript.Ide.Util

32import Language.PureScript.Ide.Util

32−import qualified Language.PureScript as P

33

34newtype Filter = Filter (Endo [Module]) deriving(Monoid)

35

@@ -65,8 +65,7 @@ identFilter predicate search =

65 where

66 filterModuleDecls :: Module -> Module

67 filterModuleDecls (moduleIdent, decls) =

68− (moduleIdent, filter (flip predicate search . getDeclaration) decls)

68+ (moduleIdent, filter (flip predicate search . discardAnn) decls)

69− getDeclaration (IdeDeclarationAnn _ d) = d

70

69

71runFilter :: Filter -> [Module] -> [Module]

70runFilter :: Filter -> [Module] -> [Module]

72runFilter (Filter f) = appEndo f

71runFilter (Filter f) = appEndo f

src/Language/PureScript/Ide/Imports.hs+28−27

@@ -30,9 +30,10 @@ module Language.PureScript.Ide.Imports

30 where

31

32import Protolude

33+

34+import Control.Lens ((^.))

35+import Data.List (findIndex, nubBy)

33import qualified Data.Text as T

36import qualified Data.Text as T

34−import Data.List (nubBy, findIndex)

35−import qualified Data.Text.IO as TIO

36import qualified Language.PureScript as P

37import qualified Language.PureScript as P

37import Language.PureScript.Ide.Completion

38import Language.PureScript.Ide.Completion

38import Language.PureScript.Ide.Error

39import Language.PureScript.Ide.Error

@@ -40,6 +41,7 @@ import Language.PureScript.Ide.Filter

40import Language.PureScript.Ide.State

41import Language.PureScript.Ide.State

41import Language.PureScript.Ide.Types

42import Language.PureScript.Ide.Types

42import Language.PureScript.Ide.Util

43import Language.PureScript.Ide.Util

44+import System.IO.UTF8 (readUTF8FileT, writeUTF8FileT)

43

45

44data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName)

46data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName)

45 deriving (Eq, Show)

47 deriving (Eq, Show)

@@ -70,7 +72,7 @@ compImport (Import n i q) (Import n' i' q')

70parseImportsFromFile :: (MonadIO m, MonadError PscIdeError m) =>

72parseImportsFromFile :: (MonadIO m, MonadError PscIdeError m) =>

71 FilePath -> m (P.ModuleName, [Text], [Import], [Text])

73 FilePath -> m (P.ModuleName, [Text], [Import], [Text])

72parseImportsFromFile fp = do

74parseImportsFromFile fp = do

73− file <- liftIO (TIO.readFile fp)

75+ file <- liftIO (readUTF8FileT fp)

74 case sliceImportSection (T.lines file) of

76 case sliceImportSection (T.lines file) of

75 Right res -> pure res

77 Right res -> pure res

76 Left err -> throwError (GeneralError err)

78 Left err -> throwError (GeneralError err)

@@ -197,16 +199,16 @@ addExplicitImport' decl moduleName imports =

197 then imports

199 then imports

198 else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports

200 else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports

199 where

201 where

200− refFromDeclaration (IdeTypeClass n) =

202+ refFromDeclaration (IdeDeclTypeClass n) =

201 P.TypeClassRef n

203 P.TypeClassRef n

202− refFromDeclaration (IdeDataConstructor n tn _) =

204+ refFromDeclaration (IdeDeclDataConstructor dtor) =

203− P.TypeRef tn (Just [n])

205+ P.TypeRef (dtor ^. ideDtorTypeName) Nothing

204− refFromDeclaration (IdeType n _) =

206+ refFromDeclaration (IdeDeclType t) =

205− P.TypeRef n (Just [])

207+ P.TypeRef (t ^. ideTypeName) (Just [])

206− refFromDeclaration (IdeValueOperator op _ _ _ _) =

208+ refFromDeclaration (IdeDeclValueOperator op) =

207− P.ValueOpRef op

209+ P.ValueOpRef (op ^. ideValueOpName)

208− refFromDeclaration (IdeTypeOperator op _ _ _ _) =

210+ refFromDeclaration (IdeDeclTypeOperator op) =

209− P.TypeOpRef op

211+ P.TypeOpRef (op ^. ideTypeOpName)

210 refFromDeclaration d =

212 refFromDeclaration d =

211 P.ValueRef $ P.Ident $ T.unpack (identifierFromIdeDeclaration d)

213 P.ValueRef $ P.Ident $ T.unpack (identifierFromIdeDeclaration d)

212

214

@@ -214,20 +216,19 @@ addExplicitImport' decl moduleName imports =

214 -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe)

216 -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe)

215 insertDeclIntoImport :: IdeDeclaration -> Import -> Import

217 insertDeclIntoImport :: IdeDeclaration -> Import -> Import

216 insertDeclIntoImport decl' (Import mn (P.Explicit refs) Nothing) =

218 insertDeclIntoImport decl' (Import mn (P.Explicit refs) Nothing) =

217− Import mn (P.Explicit (insertDeclIntoRefs decl' refs)) Nothing

219+ Import mn (P.Explicit (sortBy P.compDecRef (insertDeclIntoRefs decl' refs))) Nothing

218 insertDeclIntoImport _ is = is

220 insertDeclIntoImport _ is = is

219

221

220 insertDeclIntoRefs :: IdeDeclaration -> [P.DeclarationRef] -> [P.DeclarationRef]

222 insertDeclIntoRefs :: IdeDeclaration -> [P.DeclarationRef] -> [P.DeclarationRef]

221− insertDeclIntoRefs (IdeDataConstructor dtor tn _) refs =

223+ insertDeclIntoRefs d@(IdeDeclDataConstructor dtor) refs =

222− updateAtFirstOrPrepend (matchType tn) (insertDtor dtor) (P.TypeRef tn (Just [dtor])) refs

224+ updateAtFirstOrPrepend

225+ (matchType (dtor ^. ideDtorTypeName))

226+ (insertDtor (dtor ^. ideDtorName))

227+ (refFromDeclaration d)

228+ refs

223 insertDeclIntoRefs dr refs = nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs)

229 insertDeclIntoRefs dr refs = nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs)

224

230

225− insertDtor dtor (P.TypeRef tn' dtors) =

231+ insertDtor _ (P.TypeRef tn' _) = P.TypeRef tn' Nothing

226− case dtors of

227− Just dtors' -> P.TypeRef tn' (Just (ordNub (dtor : dtors')))

228− -- This means the import was opened. We don't add anything in this case

229− -- import Data.Maybe (Maybe(..)) -> import Data.Maybe (Maybe(Just))

230− Nothing -> P.TypeRef tn' Nothing

231 insertDtor _ refs = refs

232 insertDtor _ refs = refs

232

233

233 matchType :: P.ProperName 'P.TypeName -> P.DeclarationRef -> Bool

234 matchType :: P.ProperName 'P.TypeName -> P.DeclarationRef -> Bool

@@ -294,9 +295,9 @@ addImportForIdentifier fp ident filters = do

294 xs ->

295 xs ->

295 pure $ Left xs

296 pure $ Left xs

296 where

297 where

297− decideRedundantCase dtor@(IdeDataConstructor _ t _) (IdeType t' _) =

298+ decideRedundantCase d@(IdeDeclDataConstructor dtor) (IdeDeclType t) =

298− if t == t' then Just dtor else Nothing

299+ if dtor ^. ideDtorTypeName == t ^. ideTypeName then Just d else Nothing

299− decideRedundantCase IdeType{} ts@IdeTypeSynonym{} =

300+ decideRedundantCase IdeDeclType{} ts@IdeDeclTypeSynonym{} =

300 Just ts

301 Just ts

301 decideRedundantCase _ _ = Nothing

302 decideRedundantCase _ _ = Nothing

302

303

@@ -316,10 +317,10 @@ prettyPrintImportSection imports = map prettyPrintImport' (sort imports)

316answerRequest :: (MonadIO m) => Maybe FilePath -> [Text] -> m Success

317answerRequest :: (MonadIO m) => Maybe FilePath -> [Text] -> m Success

317answerRequest outfp rs =

318answerRequest outfp rs =

318 case outfp of

319 case outfp of

319− Nothing -> pure $ MultilineTextResult rs

320+ Nothing -> pure (MultilineTextResult rs)

320 Just outfp' -> do

321 Just outfp' -> do

321− liftIO $ TIO.writeFile outfp' (T.unlines rs)

322+ liftIO (writeUTF8FileT outfp' (T.unlines rs))

322− pure $ TextResult $ "Written to " <> T.pack outfp'

323+ pure (TextResult ("Written to " <> T.pack outfp'))

323

324

324-- | Test and ghci helper

325-- | Test and ghci helper

325parseImport :: Text -> Maybe Import

326parseImport :: Text -> Maybe Import

src/Language/PureScript/Ide/Matcher.hs+1−1

@@ -12,9 +12,9 @@

12-- Matchers for psc-ide commands

13-----------------------------------------------------------------------------

14

15+{-# LANGUAGE FlexibleInstances #-}

15{-# LANGUAGE GeneralizedNewtypeDeriving #-}

16{-# LANGUAGE GeneralizedNewtypeDeriving #-}

16{-# LANGUAGE OverloadedStrings #-}

17{-# LANGUAGE OverloadedStrings #-}

17−{-# LANGUAGE FlexibleInstances #-}

18

19module Language.PureScript.Ide.Matcher

20 ( Matcher

src/Language/PureScript/Ide/Pursuit.hs+25−21

@@ -12,7 +12,7 @@

12-- Pursuit client for psc-ide

13-----------------------------------------------------------------------------

14

15−{-# LANGUAGE OverloadedStrings #-}

15+{-# LANGUAGE OverloadedStrings #-}

16

17module Language.PureScript.Ide.Pursuit

18 ( searchPursuitForDeclarations

@@ -35,37 +35,41 @@ import qualified Pipes.Prelude as P

35-- TODO: remove this when the issue is fixed at Pursuit

36queryPursuit :: Text -> IO ByteString

37queryPursuit q = do

38− let qClean = T.dropWhileEnd (== '.') q

38+ let qClean = T.dropWhileEnd (== '.') q

39− req' <- parseRequest "http://pursuit.purescript.org/search"

39+ req' <- parseRequest "http://pursuit.purescript.org/search"

40− let req = req'

40+ let req = req'

41− { queryString= "q=" <> (fromString . T.unpack) qClean

41+ { queryString= "q=" <> (fromString . T.unpack) qClean

42− , requestHeaders=[(hAccept, "application/json")]

42+ , requestHeaders=[(hAccept, "application/json")]

43− }

43+ }

44− m <- newManager tlsManagerSettings

44+ m <- newManager tlsManagerSettings

45− withHTTP req m $ \resp ->

45+ withHTTP req m $ \resp ->

46− P.fold (<>) "" identity (responseBody resp)

46+ P.fold (<>) "" identity (responseBody resp)

47+

47

48

48handler :: HttpException -> IO [a]

49handler :: HttpException -> IO [a]

50+handler StatusCodeException{} = pure []

49handler _ = pure []

51handler _ = pure []

50

52

51searchPursuitForDeclarations :: Text -> IO [PursuitResponse]

53searchPursuitForDeclarations :: Text -> IO [PursuitResponse]

52−searchPursuitForDeclarations query = E.handle handler $ do

54+searchPursuitForDeclarations query =

53− r <- queryPursuit query

55+ (do r <- queryPursuit query

54− let results' = decode (fromStrict r) :: Maybe Array

56+ let results' = decode (fromStrict r) :: Maybe Array

55− case results' of

57+ case results' of

56− Nothing -> pure []

58+ Nothing -> pure []

57− Just results -> pure (mapMaybe (isDeclarationResponse . fromJSON) (toList results))

59+ Just results -> pure (mapMaybe (isDeclarationResponse . fromJSON) (toList results))) `E.catch`

60+ handler

58 where

61 where

59 isDeclarationResponse (Success a@DeclarationResponse{}) = Just a

62 isDeclarationResponse (Success a@DeclarationResponse{}) = Just a

60 isDeclarationResponse _ = Nothing

63 isDeclarationResponse _ = Nothing

61

64

62findPackagesForModuleIdent :: Text -> IO [PursuitResponse]

65findPackagesForModuleIdent :: Text -> IO [PursuitResponse]

63−findPackagesForModuleIdent query = E.handle handler $ do

66+findPackagesForModuleIdent query =

64− r <- queryPursuit query

67+ (do r <- queryPursuit query

65− let results' = decode (fromStrict r) :: Maybe Array

68+ let results' = decode (fromStrict r) :: Maybe Array

66− case results' of

69+ case results' of

67 Nothing -> pure []

70 Nothing -> pure []

68− Just results -> pure (mapMaybe (isModuleResponse . fromJSON) (toList results))

71+ Just results -> pure (mapMaybe (isModuleResponse . fromJSON) (toList results))) `E.catch`

72+ handler

69 where

73 where

70 isModuleResponse (Success a@ModuleResponse{}) = Just a

74 isModuleResponse (Success a@ModuleResponse{}) = Just a

71 isModuleResponse _ = Nothing

75 isModuleResponse _ = Nothing

src/Language/PureScript/Ide/Rebuild.hs+3−3

@@ -11,7 +11,7 @@ module Language.PureScript.Ide.Rebuild

11import Protolude

12

13import "monad-logger" Control.Monad.Logger

14−import qualified Data.List as List

14+import qualified Data.List as List

15import qualified Data.Map.Lazy as M

16import Data.Maybe (fromJust)

17import qualified Data.Set as S

@@ -21,7 +21,7 @@ import Language.PureScript.Ide.Error

21import Language.PureScript.Ide.State

22import Language.PureScript.Ide.Types

23import Language.PureScript.Ide.Util

24−import System.IO.UTF8 (readUTF8File)

24+import System.IO.UTF8 (readUTF8FileT)

25

26-- | Given a filepath performs the following steps:

27--

@@ -44,7 +44,7 @@ rebuildFile

44 -> m Success

45rebuildFile path = do

46

47− input <- liftIO (readUTF8File path)

47+ input <- liftIO (readUTF8FileT path)

48

49 m <- case snd <$> P.parseModuleFromFile identity (path, input) of

50 Left parseError -> throwError

src/Language/PureScript/Ide/Reexports.hs+13−16

@@ -25,16 +25,18 @@ module Language.PureScript.Ide.Reexports

25

26import Protolude

27

28+import Control.Lens hiding ((&))

29+

28import qualified Data.Map as Map

30import qualified Data.Map as Map

31+import qualified Language.PureScript as P

29import Language.PureScript.Ide.Types

32import Language.PureScript.Ide.Types

30import Language.PureScript.Ide.Util

33import Language.PureScript.Ide.Util

31−import qualified Language.PureScript as P

32

34

33-- | Contains the module with resolved reexports, and eventual failures

35-- | Contains the module with resolved reexports, and eventual failures

34data ReexportResult a

36data ReexportResult a

35 = ReexportResult

37 = ReexportResult

36 { reResolved :: a

38 { reResolved :: a

37− , reFailed :: [(P.ModuleName, P.DeclarationRef)]

39+ , reFailed :: [(P.ModuleName, P.DeclarationRef)]

38 } deriving (Show, Eq, Functor)

40 } deriving (Show, Eq, Functor)

39

41

40-- | Uses the passed formatter to format the resolved module, and adds eventual

42-- | Uses the passed formatter to format the resolved module, and adds eventual

@@ -79,7 +81,7 @@ resolveRef

79 -> Either P.DeclarationRef [IdeDeclarationAnn]

81 -> Either P.DeclarationRef [IdeDeclarationAnn]

80resolveRef decls ref = case ref of

82resolveRef decls ref = case ref of

81 P.TypeRef tn mdtors ->

83 P.TypeRef tn mdtors ->

82− case findRef (\case IdeType name _ -> name == tn; _ -> False) of

84+ case findRef (\x -> x ^? _IdeDeclType . ideTypeName <&> (== tn) & fromMaybe False) of

83 Nothing -> Left ref

85 Nothing -> Left ref

84 Just d -> Right $ d : case mdtors of

86 Just d -> Right $ d : case mdtors of

85 Nothing ->

87 Nothing ->

@@ -89,28 +91,23 @@ resolveRef decls ref = case ref of

89 findDtors tn

91 findDtors tn

90 Just dtors -> mapMaybe lookupDtor dtors

92 Just dtors -> mapMaybe lookupDtor dtors

91 P.ValueRef i ->

93 P.ValueRef i ->

92− findWrapped (\case IdeValue i' _ -> i' == i; _ -> False)

94+ findWrapped (\x -> x ^? _IdeDeclValue . ideValueIdent <&> (== i) & fromMaybe False)

93− P.TypeOpRef name ->

94− findWrapped (\case IdeTypeOperator n _ _ _ _ -> n == name; _ -> False)

95 P.ValueOpRef name ->

96− findWrapped (\case IdeValueOperator n _ _ _ _ -> n == name; _ -> False)

96+ findWrapped (\x -> x ^? _IdeDeclValueOperator . ideValueOpName <&> (== name) & fromMaybe False)

97+ P.TypeOpRef name ->

98+ findWrapped (\x -> x ^? _IdeDeclTypeOperator . ideTypeOpName <&> (== name) & fromMaybe False)

97 P.TypeClassRef name ->

99 P.TypeClassRef name ->

98− findWrapped (\case IdeTypeClass n -> n == name; _ -> False)

100+ findWrapped (\case IdeDeclTypeClass n -> n == name; _ -> False)

99 _ ->

101 _ ->

100 Left ref

102 Left ref

101 where

103 where

102− findWrapped = wrapSingle . findRef

103− wrapSingle = maybe (Left ref) (Right . pure)

104+ findWrapped = maybe (Left ref) (Right . pure) . findRef

104 findRef f = find (f . discardAnn) decls

105 findRef f = find (f . discardAnn) decls

105

106

106 lookupDtor name =

107 lookupDtor name =

107− findRef (\case IdeDataConstructor name' _ _ -> name == name'

108+ findRef (\x -> x ^? _IdeDeclDataConstructor . ideDtorName <&> (== name) & fromMaybe False)

108− _ -> False)

109

110 findDtors tn = filter (f . discardAnn) decls

111 where

112 f :: IdeDeclaration -> Bool

113− f decl

113+ f decl = decl ^? _IdeDeclDataConstructor . ideDtorTypeName <&> (== tn) & fromMaybe False

114− | (IdeDataConstructor _ tn' _) <- decl

115− , tn == tn' = True

116− | otherwise = False

src/Language/PureScript/Ide/SourceFile.hs+7−7

@@ -12,7 +12,7 @@

12-- Getting declarations from PureScript sourcefiles

13-----------------------------------------------------------------------------

14

15−{-# LANGUAGE OverloadedStrings #-}

15+{-# LANGUAGE OverloadedStrings #-}

16

17module Language.PureScript.Ide.SourceFile

18 ( parseModule

@@ -25,19 +25,19 @@ module Language.PureScript.Ide.SourceFile

25

26import Protolude

27

28−import qualified Data.Map as Map

28+import qualified Data.Map as Map

29−import qualified Language.PureScript as P

29+import qualified Language.PureScript as P

30import Language.PureScript.Ide.Error

31−import Language.PureScript.Ide.Util

32import Language.PureScript.Ide.Types

31import Language.PureScript.Ide.Types

33−import System.IO.UTF8 (readUTF8File)

32+import Language.PureScript.Ide.Util

33+import System.IO.UTF8 (readUTF8FileT)

34

35parseModule

36 :: (MonadIO m)

37 => FilePath

38− -> m (Either FilePath (FilePath, P.Module) )

38+ -> m (Either FilePath (FilePath, P.Module))

39parseModule path = do

40− contents <- liftIO (readUTF8File path)

40+ contents <- liftIO (readUTF8FileT path)

41 case P.parseModuleFromFile identity (path, contents) of

42 Left _ -> pure (Left path)

43 Right m -> pure (Right m)

src/Language/PureScript/Ide/State.hs+37−45

@@ -32,20 +32,20 @@ module Language.PureScript.Ide.State

32 , resolveOperatorsForModule

33 ) where

34

35−import Protolude

36import qualified Prelude

35import qualified Prelude

36+import Protolude

37

38import Control.Concurrent.STM

39+import Control.Lens hiding (op, (&))

39import "monad-logger" Control.Monad.Logger

40import "monad-logger" Control.Monad.Logger

40−import qualified Data.Map.Lazy as Map

41+import qualified Data.Map.Lazy as Map

41−import qualified Data.List as List

42+import qualified Language.PureScript as P

42import Language.PureScript.Externs

43import Language.PureScript.Externs

43import Language.PureScript.Ide.Externs

44import Language.PureScript.Ide.Externs

44import Language.PureScript.Ide.Reexports

45import Language.PureScript.Ide.Reexports

45import Language.PureScript.Ide.SourceFile

46import Language.PureScript.Ide.SourceFile

46import Language.PureScript.Ide.Types

47import Language.PureScript.Ide.Types

47import Language.PureScript.Ide.Util

48import Language.PureScript.Ide.Util

48−import qualified Language.PureScript as P

49import System.Clock

50

51-- | Resets all State inside psc-ide

@@ -235,47 +235,39 @@ resolveOperatorsForModule

235 :: Map P.ModuleName [IdeDeclarationAnn]

236 -> [IdeDeclarationAnn]

237 -> [IdeDeclarationAnn]

238−resolveOperatorsForModule modules = map (mapIdeDeclaration resolveOperator)

238+resolveOperatorsForModule modules = map ((over idaDeclaration) resolveOperator)

239 where

240+ hasName :: Eq b => Lens' a b -> b -> a -> Bool

241+ hasName l a x = x ^. l == a

242+

243+ getDeclarations :: P.ModuleName -> [IdeDeclaration]

244+ getDeclarations moduleName =

245+ Map.lookup moduleName modules

246+ & fromMaybe []

247+ & map discardAnn

248+

240− resolveOperator (IdeValueOperator

249+ resolveOperator (IdeDeclValueOperator op)

241− opName

242− i@(P.Qualified (Just moduleName)

250+ | (P.Qualified (Just mn) (Left ident)) <- op ^. ideValueOpAlias =

243− (Left ident)) precedence assoc _) =

251+ let t = getDeclarations mn

244− let t = do

252+ & mapMaybe (preview _IdeDeclValue)

245− sourceModule <- Map.lookup moduleName modules

253+ & filter (hasName ideValueIdent ident)

246− IdeValue _ tP <-

254+ & map (view ideValueType)

247− List.find (\case

255+ & listToMaybe

248− IdeValue iP _ -> iP == ident

256+ in IdeDeclValueOperator (op & ideValueOpType .~ t)

249− _ -> False) (discardAnn <$> sourceModule)

250− pure tP

251−

252− in IdeValueOperator opName i precedence assoc t

253− resolveOperator (IdeValueOperator

254− opName

255− i@(P.Qualified (Just moduleName)

257+ | (P.Qualified (Just mn) (Right dtor)) <- op ^. ideValueOpAlias =

256− (Right ctor)) precedence assoc _) =

258+ let t = getDeclarations mn

257− let t = do

259+ & mapMaybe (preview _IdeDeclDataConstructor)

258− sourceModule <- Map.lookup moduleName modules

260+ & filter (hasName ideDtorName dtor)

259− IdeDataConstructor _ _ tP <-

261+ & map (view ideDtorType)

260− List.find (\case

262+ & listToMaybe

261− IdeDataConstructor cname _ _ -> ctor == cname

263+ in IdeDeclValueOperator (op & ideValueOpType .~ t)

262− _ -> False) (discardAnn <$> sourceModule)

263− pure tP

264−

265− in IdeValueOperator opName i precedence assoc t

266− resolveOperator (IdeTypeOperator

264+ resolveOperator (IdeDeclTypeOperator op)

267− opName

268− i@(P.Qualified (Just moduleName) properName) precedence assoc _) =

265+ | P.Qualified (Just mn) properName <- op ^. ideTypeOpAlias =

269− let k = do

266+ let k = getDeclarations mn

270− sourceModule <- Map.lookup moduleName modules

267+ & mapMaybe (preview _IdeDeclType)

271− IdeType _ kP <-

268+ & filter (hasName ideTypeName properName)

272− List.find (\case

269+ & map (view ideTypeKind)

273− IdeType name _ -> name == properName

270+ & listToMaybe

274− _ -> False) (discardAnn <$> sourceModule)

271+ in IdeDeclTypeOperator (op & ideTypeOpKind .~ k)

275− pure kP

276−

277− in IdeTypeOperator opName i precedence assoc k

278 resolveOperator x = x

272 resolveOperator x = x

279

273

280−mapIdeDeclaration :: (IdeDeclaration -> IdeDeclaration) -> IdeDeclarationAnn -> IdeDeclarationAnn

281−mapIdeDeclaration f (IdeDeclarationAnn ann decl) = IdeDeclarationAnn ann (f decl)

src/Language/PureScript/Ide/Types.hs+72−21

@@ -12,42 +12,93 @@

12-- Type definitions for psc-ide

13-----------------------------------------------------------------------------

14

15−{-# LANGUAGE OverloadedStrings #-}

16{-# LANGUAGE DeriveFoldable #-}

15{-# LANGUAGE DeriveFoldable #-}

16+{-# LANGUAGE OverloadedStrings #-}

17+{-# LANGUAGE TemplateHaskell #-}

17

18

18module Language.PureScript.Ide.Types where

19module Language.PureScript.Ide.Types where

19

20

20import Protolude

21import Protolude

21

22

22import Control.Concurrent.STM

23import Control.Concurrent.STM

24+import Control.Lens.TH

23import Data.Aeson

25import Data.Aeson

24−import qualified Data.Map.Lazy as M

26+import qualified Data.Map.Lazy as M

25−import qualified Language.PureScript.Errors.JSON as P

27+import qualified Language.PureScript as P

26−import qualified Language.PureScript as P

28+import qualified Language.PureScript.Errors.JSON as P

27import Language.PureScript.Ide.Conversions

29import Language.PureScript.Ide.Conversions

28

30

29type ModuleIdent = Text

31type ModuleIdent = Text

30

32

31data IdeDeclaration

33data IdeDeclaration

32− = IdeValue P.Ident P.Type

34+ = IdeDeclValue IdeValue

33− | IdeType (P.ProperName 'P.TypeName) P.Kind

35+ | IdeDeclType IdeType

34− | IdeTypeSynonym (P.ProperName 'P.TypeName) P.Type

36+ | IdeDeclTypeSynonym IdeSynonym

35− | IdeDataConstructor (P.ProperName 'P.ConstructorName) (P.ProperName 'P.TypeName) P.Type

37+ | IdeDeclDataConstructor IdeDataConstructor

36− | IdeTypeClass (P.ProperName 'P.ClassName)

38+ | IdeDeclTypeClass (P.ProperName 'P.ClassName)

37− | IdeValueOperator (P.OpName 'P.ValueOpName) (P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName))) P.Precedence P.Associativity (Maybe P.Type)

39+ | IdeDeclValueOperator IdeValueOperator

38− | IdeTypeOperator (P.OpName 'P.TypeOpName) (P.Qualified (P.ProperName 'P.TypeName)) P.Precedence P.Associativity (Maybe P.Kind)

40+ | IdeDeclTypeOperator IdeTypeOperator

39 deriving (Show, Eq, Ord)

41 deriving (Show, Eq, Ord)

40

42

43+data IdeValue = IdeValue

44+ { _ideValueIdent :: P.Ident

45+ , _ideValueType :: P.Type

46+ } deriving (Show, Eq, Ord)

47+

48+data IdeType = IdeType

49+ { _ideTypeName :: P.ProperName 'P.TypeName

50+ , _ideTypeKind :: P.Kind

51+ } deriving (Show, Eq, Ord)

52+

53+data IdeSynonym = IdeSynonym

54+ { _ideSynonymName :: P.ProperName 'P.TypeName

55+ , _ideSynonymType :: P.Type

56+ } deriving (Show, Eq, Ord)

57+

58+data IdeDataConstructor = IdeDataConstructor

59+ { _ideDtorName :: P.ProperName 'P.ConstructorName

60+ , _ideDtorTypeName :: P.ProperName 'P.TypeName

61+ , _ideDtorType :: P.Type

62+ } deriving (Show, Eq, Ord)

63+

64+data IdeValueOperator = IdeValueOperator

65+ { _ideValueOpName :: P.OpName 'P.ValueOpName

66+ , _ideValueOpAlias :: P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName))

67+ , _ideValueOpPrecedence :: P.Precedence

68+ , _ideValueOpAssociativity :: P.Associativity

69+ , _ideValueOpType :: Maybe P.Type

70+ } deriving (Show, Eq, Ord)

71+

72+data IdeTypeOperator = IdeTypeOperator

73+ { _ideTypeOpName :: P.OpName 'P.TypeOpName

74+ , _ideTypeOpAlias :: P.Qualified (P.ProperName 'P.TypeName)

75+ , _ideTypeOpPrecedence :: P.Precedence

76+ , _ideTypeOpAssociativity :: P.Associativity

77+ , _ideTypeOpKind :: Maybe P.Kind

78+ } deriving (Show, Eq, Ord)

79+

80+makePrisms ''IdeDeclaration

81+makeLenses ''IdeValue

82+makeLenses ''IdeType

83+makeLenses ''IdeSynonym

84+makeLenses ''IdeDataConstructor

85+makeLenses ''IdeValueOperator

86+makeLenses ''IdeTypeOperator

87+

41−data IdeDeclarationAnn = IdeDeclarationAnn Annotation IdeDeclaration

88+data IdeDeclarationAnn = IdeDeclarationAnn

89+ { _idaAnnotation :: Annotation

90+ , _idaDeclaration :: IdeDeclaration

42− deriving (Show, Eq, Ord)

91+ } deriving (Show, Eq, Ord)

43

92

44data Annotation

93data Annotation

45 = Annotation

94 = Annotation

46− { annLocation :: Maybe P.SourceSpan

95+ { annLocation :: Maybe P.SourceSpan

47− , annExportedFrom :: Maybe P.ModuleName

96+ , annExportedFrom :: Maybe P.ModuleName

48 , annTypeAnnotation :: Maybe P.Type

97 , annTypeAnnotation :: Maybe P.Type

49 } deriving (Show, Eq, Ord)

98 } deriving (Show, Eq, Ord)

50

99

100+makeLenses ''IdeDeclarationAnn

101+

51emptyAnn :: Annotation

102emptyAnn :: Annotation

52emptyAnn = Annotation Nothing Nothing Nothing

103emptyAnn = Annotation Nothing Nothing Nothing

53

104

@@ -103,7 +154,7 @@ data Stage2 = Stage2

103 }

154 }

104

155

105data Stage3 = Stage3

156data Stage3 = Stage3

106− { s3Declarations :: M.Map P.ModuleName [IdeDeclarationAnn]

157+ { s3Declarations :: M.Map P.ModuleName [IdeDeclarationAnn]

107 , s3CachedRebuild :: Maybe (P.ModuleName, P.ExternsFile)

158 , s3CachedRebuild :: Maybe (P.ModuleName, P.ExternsFile)

108 }

159 }

109

160

@@ -112,11 +163,11 @@ newtype Match a = Match (P.ModuleName, a)

112

163

113-- | A completion as it gets sent to the editors

164-- | A completion as it gets sent to the editors

114data Completion = Completion

165data Completion = Completion

115− { complModule :: Text

166+ { complModule :: Text

116− , complIdentifier :: Text

167+ , complIdentifier :: Text

117− , complType :: Text

168+ , complType :: Text

118− , complExpandedType :: Text

169+ , complExpandedType :: Text

119− , complLocation :: Maybe P.SourceSpan

170+ , complLocation :: Maybe P.SourceSpan

120 , complDocumentation :: Maybe Text

171 , complDocumentation :: Maybe Text

121 } deriving (Show, Eq)

172 } deriving (Show, Eq)

122

173

src/Language/PureScript/Ide/Util.hs+26−24

@@ -29,23 +29,25 @@ module Language.PureScript.Ide.Util

29 , module Language.PureScript.Ide.Conversions

30 ) where

31

32−import Protolude hiding (decodeUtf8, encodeUtf8)

32+import Control.Lens ((^.))

33import Data.Aeson

34−import qualified Data.Text as T

34+import qualified Data.Text as T

35−import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)

35+import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)

36−import qualified Language.PureScript as P

36+import qualified Language.PureScript as P

37−import Language.PureScript.Ide.Types

38import Language.PureScript.Ide.Conversions

37import Language.PureScript.Ide.Conversions

38+import Language.PureScript.Ide.Types

39+import Protolude hiding (decodeUtf8,

40+ encodeUtf8)

39

41

40identifierFromIdeDeclaration :: IdeDeclaration -> Text

42identifierFromIdeDeclaration :: IdeDeclaration -> Text

41identifierFromIdeDeclaration d = case d of

43identifierFromIdeDeclaration d = case d of

42− IdeValue name _ -> runIdentT name

44+ IdeDeclValue v -> v ^. ideValueIdent . identT

43− IdeType name _ -> runProperNameT name

45+ IdeDeclType t -> t ^. ideTypeName . properNameT

44− IdeTypeSynonym name _ -> runProperNameT name

46+ IdeDeclTypeSynonym s -> s ^. ideSynonymName . properNameT

45− IdeDataConstructor name _ _ -> runProperNameT name

47+ IdeDeclDataConstructor dtor -> dtor ^. ideDtorName . properNameT

46− IdeTypeClass name -> runProperNameT name

48+ IdeDeclTypeClass name -> runProperNameT name

47− IdeValueOperator op _ _ _ _ -> runOpNameT op

49+ IdeDeclValueOperator op -> op ^. ideValueOpName & runOpNameT

48− IdeTypeOperator op _ _ _ _ -> runOpNameT op

50+ IdeDeclTypeOperator op -> op ^. ideTypeOpName & runOpNameT

49

51

50discardAnn :: IdeDeclarationAnn -> IdeDeclaration

52discardAnn :: IdeDeclarationAnn -> IdeDeclaration

51discardAnn (IdeDeclarationAnn _ d) = d

53discardAnn (IdeDeclarationAnn _ d) = d

@@ -61,24 +63,24 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) =

61 Completion {..}

63 Completion {..}

62 where

64 where

63 (complIdentifier, complExpandedType) = case decl of

65 (complIdentifier, complExpandedType) = case decl of

64− IdeValue name type' -> (runIdentT name, prettyTypeT type')

66+ IdeDeclValue v -> (v ^. ideValueIdent . identT, v ^. ideValueType & prettyTypeT)

65− IdeType name kind -> (runProperNameT name, toS (P.prettyPrintKind kind))

67+ IdeDeclType t -> (t ^. ideTypeName . properNameT, t ^. ideTypeKind & P.prettyPrintKind & toS )

66− IdeTypeSynonym name kind -> (runProperNameT name, prettyTypeT kind)

68+ IdeDeclTypeSynonym s -> (s ^. ideSynonymName . properNameT, s ^. ideSynonymType & prettyTypeT)

67− IdeDataConstructor name _ type' -> (runProperNameT name, prettyTypeT type')

69+ IdeDeclDataConstructor d -> (d ^. ideDtorName . properNameT, d ^. ideDtorType & prettyTypeT)

68− IdeTypeClass name -> (runProperNameT name, "class")

70+ IdeDeclTypeClass name -> (runProperNameT name, "class")

69− IdeValueOperator op ref precedence associativity typeP ->

71+ IdeDeclValueOperator (IdeValueOperator op ref precedence associativity typeP) ->

70− (runOpNameT op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP)

72+ (runOpNameT op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP)

71− IdeTypeOperator op ref precedence associativity kind ->

73+ IdeDeclTypeOperator (IdeTypeOperator op ref precedence associativity kind) ->

72 (runOpNameT op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) (toS . P.prettyPrintKind) kind)

74 (runOpNameT op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) (toS . P.prettyPrintKind) kind)

73−

75+

74 complModule = runModuleNameT m

76 complModule = runModuleNameT m

75

77

76 complType = maybe complExpandedType prettyTypeT (annTypeAnnotation ann)

78 complType = maybe complExpandedType prettyTypeT (annTypeAnnotation ann)

77−

79+

78 complLocation = annLocation ann

80 complLocation = annLocation ann

79

81

80 complDocumentation = Nothing

82 complDocumentation = Nothing

81−

83+

82 showFixity p a r o =

84 showFixity p a r o =

83 let asso = case a of

85 let asso = case a of

84 P.Infix -> "infix"

86 P.Infix -> "infix"

@@ -95,7 +97,7 @@ typeOperatorAliasT

95 :: P.Qualified (P.ProperName 'P.TypeName) -> Text

97 :: P.Qualified (P.ProperName 'P.TypeName) -> Text

96typeOperatorAliasT i =

98typeOperatorAliasT i =

97 toS (P.showQualified P.runProperName i)

99 toS (P.showQualified P.runProperName i)

98−

100+

99encodeT :: (ToJSON a) => a -> Text

101encodeT :: (ToJSON a) => a -> Text

100encodeT = toS . decodeUtf8 . encode

102encodeT = toS . decodeUtf8 . encode

101

103

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

@@ -104,7 +104,7 @@ handleCommand _ _ (KindOf typ) = handleKindOf typ

104handleCommand _ _ (BrowseModule moduleName) = handleBrowse moduleName

105handleCommand _ _ (ShowInfo QueryLoaded) = handleShowLoadedModules

106handleCommand _ _ (ShowInfo QueryImport) = handleShowImportedModules

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

107+handleCommand _ _ _ = P.internalError "handleCommand: unexpected command"

108

109-- | Reset the application state

110handleResetState

src/Language/PureScript/Interactive/Completion.hs+1

@@ -122,6 +122,7 @@ directiveArg _ Browse = [CtxModule]

122directiveArg _ Quit = []

123directiveArg _ Reset = []

124directiveArg _ Help = []

125+directiveArg _ Paste = []

125directiveArg _ Show = map CtxFixed replQueryStrings

126directiveArg _ Show = map CtxFixed replQueryStrings

126directiveArg _ Type = [CtxIdentifier]

127directiveArg _ Type = [CtxIdentifier]

127directiveArg _ Kind = [CtxType]

128directiveArg _ Kind = [CtxType]

src/Language/PureScript/Interactive/Directive.hs+3

@@ -30,6 +30,7 @@ directiveStrings =

30 , (Type , ["type"])

31 , (Kind , ["kind"])

32 , (Show , ["show"])

33+ , (Paste , ["paste"])

33 ]

34 ]

34

35

35-- |

36-- |

@@ -82,6 +83,7 @@ hasArgument :: Directive -> Bool

82hasArgument Help = False

83hasArgument Help = False

83hasArgument Quit = False

84hasArgument Quit = False

84hasArgument Reset = False

85hasArgument Reset = False

86+hasArgument Paste = False

85hasArgument _ = True

87hasArgument _ = True

86

88

87-- |

89-- |

@@ -97,4 +99,5 @@ help =

97 , (Kind, "<type>", "Show the kind of <type>")

99 , (Kind, "<type>", "Show the kind of <type>")

98 , (Show, "import", "Show all imported modules")

100 , (Show, "import", "Show all imported modules")

99 , (Show, "loaded", "Show all loaded modules")

101 , (Show, "loaded", "Show all loaded modules")

102+ , (Paste, "paste", "Enter multiple lines, terminated by ^D")

100 ]

103 ]

src/Language/PureScript/Interactive/IO.hs+2−9

@@ -1,11 +1,11 @@

1−module Language.PureScript.Interactive.IO where

1+module Language.PureScript.Interactive.IO (findNodeProcess, getHistoryFilename) where

2

3import Prelude.Compat

4

5import Control.Monad (msum)

6import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

7import System.Directory (createDirectoryIfMissing, getHomeDirectory, findExecutable)

8−import System.FilePath (takeDirectory, (</>), isPathSeparator)

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

9

10mkdirp :: FilePath -> IO ()

11mkdirp = createDirectoryIfMissing True . takeDirectory

@@ -32,10 +32,3 @@ getHistoryFilename = do

32 let filename = home </> ".purescript" </> "psci_history"

33 mkdirp filename

34 return filename

35−

36−-- |

37−-- Expands tilde in path.

38−--

39−expandTilde :: FilePath -> IO FilePath

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

41−expandTilde p = return p

src/Language/PureScript/Interactive/Message.hs+5−1

@@ -39,11 +39,15 @@ prologueMessage = unlines

39

40supportModuleMessage :: String

41supportModuleMessage = unlines

42− [ "PSCi requires the purescript-psci-support package to be installed."

42+ [ "PSCi requires the psci-support package to be installed."

43 , "You can install it using Bower as follows:"

44 , ""

45 , " bower i purescript-psci-support --save-dev"

46 , ""

47+ , "Or using psc-package:"

48+ , ""

49+ , " psc-package install psci-support"

50+ , ""

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

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

48 ]

52 ]

49

53

src/Language/PureScript/Interactive/Module.hs+3−3

@@ -6,7 +6,7 @@ import Control.Monad

6import qualified Language.PureScript as P

7import Language.PureScript.Interactive.Types

8import System.FilePath (pathSeparator)

9−import System.IO.UTF8 (readUTF8File)

9+import System.IO.UTF8 (readUTF8FileT)

10

11-- * Support Module

12

@@ -25,7 +25,7 @@ supportModuleIsDefined = any ((== supportModuleName) . P.getModuleName)

25--

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

27loadModule filename = do

28− content <- readUTF8File filename

28+ content <- readUTF8FileT filename

29 return $ either (Left . P.prettyPrintMultipleErrors P.defaultPPEOptions) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]

30

31-- |

@@ -34,7 +34,7 @@ loadModule filename = do

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

35loadAllModules files = do

36 filesAndContent <- forM files $ \filename -> do

37− content <- readUTF8File filename

37+ content <- readUTF8FileT filename

38 return (filename, content)

39 return $ P.parseModulesFromFiles id filesAndContent

40

src/Language/PureScript/Interactive/Parser.hs+1

@@ -62,6 +62,7 @@ parseDirective cmd =

62 Help -> return ShowHelp

63 Quit -> return QuitPSCi

64 Reset -> return ResetState

65+ Paste -> return PasteLines

65 Browse -> BrowseModule <$> parseRest P.moduleName arg

66 Browse -> BrowseModule <$> parseRest P.moduleName arg

66 Show -> ShowInfo <$> parseReplQuery' (trim arg)

67 Show -> ShowInfo <$> parseReplQuery' (trim arg)

67 Type -> TypeOf <$> parseRest P.parseValue arg

68 Type -> TypeOf <$> parseRest P.parseValue arg

src/Language/PureScript/Interactive/Types.hs+13−30

@@ -72,46 +72,28 @@ updateLets f st = st { psciLetBindings = f (psciLetBindings st) }

72-- Valid Meta-commands for PSCI

73--

74data Command

75− -- |

76− -- A purescript expression

75+ -- | A purescript expression

77− --

78 = Expression P.Expr

76 = Expression P.Expr

79− -- |

80− -- Show the help (ie, list of directives)

77+ -- | Show the help (ie, list of directives)

81− --

82 | ShowHelp

78 | ShowHelp

83− -- |

84− -- Import a module from a loaded file

79+ -- | Import a module from a loaded file

85− --

86 | Import ImportedModule

80 | Import ImportedModule

87− -- |

88− -- Browse a module

81+ -- | Browse a module

89− --

90 | BrowseModule P.ModuleName

82 | BrowseModule P.ModuleName

91− -- |

92− -- Exit PSCI

83+ -- | Exit PSCI

93− --

94 | QuitPSCi

84 | QuitPSCi

95− -- |

96− -- Reset the state of the REPL

85+ -- | Reset the state of the REPL

97− --

98 | ResetState

86 | ResetState

99− -- |

100− -- Add some declarations to the current evaluation context.

87+ -- | Add some declarations to the current evaluation context

101− --

102 | Decls [P.Declaration]

88 | Decls [P.Declaration]

103− -- |

104− -- Find the type of an expression

89+ -- | Find the type of an expression

105− --

106 | TypeOf P.Expr

90 | TypeOf P.Expr

107− -- |

108− -- Find the kind of an expression

91+ -- | Find the kind of an expression

109− --

110 | KindOf P.Type

92 | KindOf P.Type

111− -- |

112− -- Shows information about the current state of the REPL

93+ -- | Shows information about the current state of the REPL

113− --

114 | ShowInfo ReplQuery

94 | ShowInfo ReplQuery

95+ -- | Paste multiple lines

96+ | PasteLines

115

97

116data ReplQuery

98data ReplQuery

117 = QueryLoaded

99 = QueryLoaded

@@ -142,4 +124,5 @@ data Directive

142 | Type

124 | Type

143 | Kind

125 | Kind

144 | Show

126 | Show

127+ | Paste

145 deriving (Eq, Show)

128 deriving (Eq, Show)

src/Language/PureScript/Linter/Imports.hs+1−1

@@ -308,7 +308,7 @@ findUsedRefs env mni qn names =

308 typesRefs

309 = map (flip TypeRef (Just [])) typesWithoutDctors

310 ++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors)

311− in classRefs ++ typeOpRefs ++ typesRefs ++ valueRefs ++ valueOpRefs

311+ in sortBy compDecRef $ classRefs ++ typeOpRefs ++ typesRefs ++ valueRefs ++ valueOpRefs

312

313 where

314

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

@@ -149,7 +149,7 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do

149 lint withPrim

150 ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do

151 [desugared] <- desugar externs [withPrim]

152− runCheck' env $ typeCheckModule desugared

152+ runCheck' (emptyCheckState env) $ typeCheckModule desugared

153 regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated

154 let mod' = Module ss coms moduleName regrouped exps

155 corefn = CF.moduleToCoreFn env' mod'

src/Language/PureScript/Parser/Common.hs+14−5

@@ -28,6 +28,12 @@ properName = ProperName <$> uname

28typeName :: TokenParser (ProperName 'TypeName)

29typeName = ProperName <$> tyname

30

31+-- |

32+-- Parse a proper name for a data constructor.

33+--

34+dataConstructorName :: TokenParser (ProperName 'ConstructorName)

35+dataConstructorName = ProperName <$> dconsname

36+

31-- |

37-- |

32-- Parse a module name

38-- Parse a module name

33--

39--

@@ -107,23 +113,26 @@ mark p = do

107-- |

113-- |

108-- Check that the current identation level matches a predicate

114-- Check that the current identation level matches a predicate

109--

115--

116+checkIndentation

117+ :: (P.Column -> String)

118+ -> (P.Column -> P.Column -> Bool)

110−checkIndentation :: (P.Column -> P.Column -> Bool) -> P.Parsec s ParseState ()

119+ -> P.Parsec s ParseState ()

111−checkIndentation rel = do

120+checkIndentation mkMsg rel = do

112 col <- P.sourceColumn <$> P.getPosition

121 col <- P.sourceColumn <$> P.getPosition

113 current <- indentationLevel <$> P.getState

122 current <- indentationLevel <$> P.getState

114− guard (col `rel` current)

123+ guard (col `rel` current) P.<?> mkMsg current

115

124

116-- |

125-- |

117-- Check that the current indentation level is past the current mark

126-- Check that the current indentation level is past the current mark

118--

127--

119indented :: P.Parsec s ParseState ()

128indented :: P.Parsec s ParseState ()

120−indented = checkIndentation (>) P.<?> "indentation"

129+indented = checkIndentation (("indentation past column " ++) . show) (>)

121

130

122-- |

131-- |

123-- Check that the current indentation level is at the same indentation as the current mark

132-- Check that the current indentation level is at the same indentation as the current mark

124--

133--

125same :: P.Parsec s ParseState ()

134same :: P.Parsec s ParseState ()

126−same = checkIndentation (==) P.<?> "no indentation"

135+same = checkIndentation (("indentation at column " ++) . show) (==)

127

136

128-- |

137-- |

129-- Read the comments from the the next token, without consuming it

138-- Read the comments from the the next token, without consuming it

src/Language/PureScript/Parser/Declarations.hs+8−7

@@ -19,6 +19,7 @@ import Prelude hiding (lex)

19

20import Data.Functor (($>))

21import Data.Maybe (fromMaybe)

22+import Data.Text (Text)

22

23

23import Control.Applicative

24import Control.Applicative

24import Control.Arrow ((+++))

25import Control.Arrow ((+++))

@@ -71,7 +72,7 @@ parseDataDeclaration = do

71 tyArgs <- many (indented *> kindedIdent)

72 tyArgs <- many (indented *> kindedIdent)

72 ctors <- P.option [] $ do

73 ctors <- P.option [] $ do

73 indented *> equals

74 indented *> equals

74− P.sepBy1 ((,) <$> properName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe

75+ P.sepBy1 ((,) <$> dataConstructorName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe

75 return $ DataDeclaration dtype name tyArgs ctors

76 return $ DataDeclaration dtype name tyArgs ctors

76

77

77parseTypeDeclaration :: TokenParser Declaration

78parseTypeDeclaration :: TokenParser Declaration

@@ -281,7 +282,7 @@ parseModulesFromFiles

281 :: forall m k

282 :: forall m k

282 . MonadError MultipleErrors m

283 . MonadError MultipleErrors m

283 => (k -> FilePath)

284 => (k -> FilePath)

284− -> [(k, String)]

285+ -> [(k, Text)]

285 -> m [(k, Module)]

286 -> m [(k, Module)]

286parseModulesFromFiles toFilePath input =

287parseModulesFromFiles toFilePath input =

287 flip parU wrapError . inParallel . flip map input $ parseModuleFromFile toFilePath

288 flip parU wrapError . inParallel . flip map input $ parseModuleFromFile toFilePath

@@ -298,11 +299,11 @@ parseModulesFromFiles toFilePath input =

298-- | Parses a single module with FilePath for eventual parsing errors

299-- | Parses a single module with FilePath for eventual parsing errors

299parseModuleFromFile

300parseModuleFromFile

300 :: (k -> FilePath)

301 :: (k -> FilePath)

301− -> (k, String)

302+ -> (k, Text)

302 -> Either P.ParseError (k, Module)

303 -> Either P.ParseError (k, Module)

303parseModuleFromFile toFilePath (k, content) = do

304parseModuleFromFile toFilePath (k, content) = do

304 let filename = toFilePath k

305 let filename = toFilePath k

305− ts <- lex filename content

306+ ts <- lex' filename content

306 m <- runTokenParser filename parseModule ts

307 m <- runTokenParser filename parseModule ts

307 pure (k, m)

308 pure (k, m)

308

309

@@ -360,7 +361,7 @@ parseVar :: TokenParser Expr

360parseVar = Var <$> C.parseQualified C.parseIdent

361parseVar = Var <$> C.parseQualified C.parseIdent

361

362

362parseConstructor :: TokenParser Expr

363parseConstructor :: TokenParser Expr

363−parseConstructor = Constructor <$> C.parseQualified C.properName

364+parseConstructor = Constructor <$> C.parseQualified C.dataConstructorName

364

365

365parseCase :: TokenParser Expr

366parseCase :: TokenParser Expr

366parseCase = Case <$> P.between (reserved "case") (C.indented *> reserved "of") (commaSep1 parseValue)

367parseCase = Case <$> P.between (reserved "case") (C.indented *> reserved "of") (commaSep1 parseValue)

@@ -494,10 +495,10 @@ parseNumberLiteral = LiteralBinder . NumericLiteral <$> (sign <*> number)

494 <|> return id

495 <|> return id

495

496

496parseNullaryConstructorBinder :: TokenParser Binder

497parseNullaryConstructorBinder :: TokenParser Binder

497−parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> pure []

498+parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.dataConstructorName <*> pure []

498

499

499parseConstructorBinder :: TokenParser Binder

500parseConstructorBinder :: TokenParser Binder

500−parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> many (C.indented *> parseBinderNoParens)

501+parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.dataConstructorName <*> many (C.indented *> parseBinderNoParens)

501

502

502parseObjectBinder:: TokenParser Binder

503parseObjectBinder:: TokenParser Binder

503parseObjectBinder = LiteralBinder <$> parseObjectLiteral (C.indented *> parseIdentifierAndBinder)

504parseObjectBinder = LiteralBinder <$> parseObjectLiteral (C.indented *> parseIdentifierAndBinder)

src/Language/PureScript/Parser/Lexer.hs+34−19

@@ -6,6 +6,7 @@ module Language.PureScript.Parser.Lexer

6 , Token()

7 , TokenParser()

8 , lex

9+ , lex'

9 , anyToken

10 , anyToken

10 , token

11 , token

11 , match

12 , match

@@ -43,6 +44,7 @@ module Language.PureScript.Parser.Lexer

43 , lname'

44 , lname'

44 , qualifier

45 , qualifier

45 , tyname

46 , tyname

47+ , dconsname

46 , uname

48 , uname

47 , uname'

49 , uname'

48 , mname

50 , mname

@@ -68,6 +70,8 @@ import Control.Monad (void, guard)

68

70

69import Data.Char (isSpace, isAscii, isSymbol, isAlphaNum)

71import Data.Char (isSpace, isAscii, isSymbol, isAlphaNum)

70import Data.Functor.Identity

72import Data.Functor.Identity

73+import Data.Text (Text)

74+import qualified Data.Text as T

71

75

72import Language.PureScript.Comments

76import Language.PureScript.Comments

73import Language.PureScript.Parser.State

77import Language.PureScript.Parser.State

@@ -153,8 +157,13 @@ data PositionedToken = PositionedToken

153instance Show PositionedToken where

157instance Show PositionedToken where

154 show = prettyPrintToken . ptToken

158 show = prettyPrintToken . ptToken

155

159

160+type Lexer u a = P.Parsec Text u a

161+

156lex :: FilePath -> String -> Either P.ParseError [PositionedToken]

162lex :: FilePath -> String -> Either P.ParseError [PositionedToken]

163+lex fp = lex' fp . T.pack

164+

165+lex' :: FilePath -> Text -> Either P.ParseError [PositionedToken]

157−lex f s = updatePositions <$> P.parse parseTokens f s

166+lex' f s = updatePositions <$> P.parse parseTokens f s

158

167

159updatePositions :: [PositionedToken] -> [PositionedToken]

168updatePositions :: [PositionedToken] -> [PositionedToken]

160updatePositions [] = []

169updatePositions [] = []

@@ -162,22 +171,22 @@ updatePositions (x:xs) = x : zipWith update (x:xs) xs

162 where

171 where

163 update PositionedToken { ptEndPos = pos } pt = pt { ptPrevEndPos = Just pos }

172 update PositionedToken { ptEndPos = pos } pt = pt { ptPrevEndPos = Just pos }

164

173

165−parseTokens :: P.Parsec String u [PositionedToken]

174+parseTokens :: Lexer u [PositionedToken]

166parseTokens = whitespace *> P.many parsePositionedToken <* P.skipMany parseComment <* P.eof

175parseTokens = whitespace *> P.many parsePositionedToken <* P.skipMany parseComment <* P.eof

167

176

168−whitespace :: P.Parsec String u ()

177+whitespace :: Lexer u ()

169whitespace = P.skipMany (P.satisfy isSpace)

178whitespace = P.skipMany (P.satisfy isSpace)

170

179

171−parseComment :: P.Parsec String u Comment

180+parseComment :: Lexer u Comment

172parseComment = (BlockComment <$> blockComment <|> LineComment <$> lineComment) <* whitespace

181parseComment = (BlockComment <$> blockComment <|> LineComment <$> lineComment) <* whitespace

173 where

182 where

174− blockComment :: P.Parsec String u String

183+ blockComment :: Lexer u String

175 blockComment = P.try $ P.string "{-" *> P.manyTill P.anyChar (P.try (P.string "-}"))

184 blockComment = P.try $ P.string "{-" *> P.manyTill P.anyChar (P.try (P.string "-}"))

176

185

177− lineComment :: P.Parsec String u String

186+ lineComment :: Lexer u String

178 lineComment = P.try $ P.string "--" *> P.manyTill P.anyChar (P.try (void (P.char '\n') <|> P.eof))

187 lineComment = P.try $ P.string "--" *> P.manyTill P.anyChar (P.try (void (P.char '\n') <|> P.eof))

179

188

180−parsePositionedToken :: P.Parsec String u PositionedToken

189+parsePositionedToken :: Lexer u PositionedToken

181parsePositionedToken = P.try $ do

190parsePositionedToken = P.try $ do

182 comments <- P.many parseComment

191 comments <- P.many parseComment

183 pos <- P.getPosition

192 pos <- P.getPosition

@@ -186,7 +195,7 @@ parsePositionedToken = P.try $ do

186 whitespace

195 whitespace

187 return $ PositionedToken pos pos' Nothing tok comments

196 return $ PositionedToken pos pos' Nothing tok comments

188

197

189−parseToken :: P.Parsec String u Token

198+parseToken :: Lexer u Token

190parseToken = P.choice

199parseToken = P.choice

191 [ P.try $ P.string "<-" *> P.notFollowedBy symbolChar *> pure LArrow

200 [ P.try $ P.string "<-" *> P.notFollowedBy symbolChar *> pure LArrow

192 , P.try $ P.string "←" *> P.notFollowedBy symbolChar *> pure LArrow

201 , P.try $ P.string "←" *> P.notFollowedBy symbolChar *> pure LArrow

@@ -225,34 +234,34 @@ parseToken = P.choice

225 ]

234 ]

226

235

227 where

236 where

228− parseLName :: P.Parsec String u String

237+ parseLName :: Lexer u String

229 parseLName = (:) <$> identStart <*> P.many identLetter

238 parseLName = (:) <$> identStart <*> P.many identLetter

230

239

231− parseUName :: P.Parsec String u String

240+ parseUName :: Lexer u String

232 parseUName = (:) <$> P.upper <*> P.many identLetter

241 parseUName = (:) <$> P.upper <*> P.many identLetter

233

242

234− parseSymbol :: P.Parsec String u String

243+ parseSymbol :: Lexer u String

235 parseSymbol = P.many1 symbolChar

244 parseSymbol = P.many1 symbolChar

236

245

237− identStart :: P.Parsec String u Char

246+ identStart :: Lexer u Char

238 identStart = P.lower <|> P.oneOf "_"

247 identStart = P.lower <|> P.oneOf "_"

239

248

240− identLetter :: P.Parsec String u Char

249+ identLetter :: Lexer u Char

241 identLetter = P.alphaNum <|> P.oneOf "_'"

250 identLetter = P.alphaNum <|> P.oneOf "_'"

242

251

243− symbolChar :: P.Parsec String u Char

252+ symbolChar :: Lexer u Char

244 symbolChar = P.satisfy isSymbolChar

253 symbolChar = P.satisfy isSymbolChar

245

254

246− parseCharLiteral :: P.Parsec String u Char

255+ parseCharLiteral :: Lexer u Char

247 parseCharLiteral = PT.charLiteral tokenParser

256 parseCharLiteral = PT.charLiteral tokenParser

248

257

249− parseStringLiteral :: P.Parsec String u String

258+ parseStringLiteral :: Lexer u String

250 parseStringLiteral = blockString <|> PT.stringLiteral tokenParser

259 parseStringLiteral = blockString <|> PT.stringLiteral tokenParser

251 where

260 where

252 delimiter = P.try (P.string "\"\"\"")

261 delimiter = P.try (P.string "\"\"\"")

253 blockString = delimiter >> P.manyTill P.anyChar delimiter

262 blockString = delimiter >> P.manyTill P.anyChar delimiter

254

263

255− parseNumber :: P.Parsec String u (Either Integer Double)

264+ parseNumber :: Lexer u (Either Integer Double)

256 parseNumber = (consumeLeadingZero >> P.parserZero) <|>

265 parseNumber = (consumeLeadingZero >> P.parserZero) <|>

257 (Right <$> P.try (PT.float tokenParser) <|>

266 (Right <$> P.try (PT.float tokenParser) <|>

258 Left <$> P.try (PT.natural tokenParser))

267 Left <$> P.try (PT.natural tokenParser))

@@ -266,7 +275,7 @@ parseToken = P.choice

266-- |

275-- |

267-- We use Text.Parsec.Token to implement the string and number lexemes

276-- We use Text.Parsec.Token to implement the string and number lexemes

268--

277--

269−langDef :: PT.GenLanguageDef String u Identity

278+langDef :: PT.GenLanguageDef Text u Identity

270langDef = PT.LanguageDef

279langDef = PT.LanguageDef

271 { PT.reservedNames = []

280 { PT.reservedNames = []

272 , PT.reservedOpNames = []

281 , PT.reservedOpNames = []

@@ -284,7 +293,7 @@ langDef = PT.LanguageDef

284-- |

293-- |

285-- A token parser based on the language definition

294-- A token parser based on the language definition

286--

295--

287−tokenParser :: PT.GenTokenParser String u Identity

296+tokenParser :: PT.GenTokenParser Text u Identity

288tokenParser = PT.makeTokenParser langDef

297tokenParser = PT.makeTokenParser langDef

289

298

290type TokenParser a = P.Parsec [PositionedToken] ParseState a

299type TokenParser a = P.Parsec [PositionedToken] ParseState a

@@ -452,6 +461,12 @@ tyname = token go P.<?> "type name"

452 go (UName s) = Just s

461 go (UName s) = Just s

453 go _ = Nothing

462 go _ = Nothing

454

463

464+dconsname :: TokenParser String

465+dconsname = token go P.<?> "data constructor name"

466+ where

467+ go (UName s) = Just s

468+ go _ = Nothing

469+

455mname :: TokenParser String

470mname :: TokenParser String

456mname = token go P.<?> "module name"

471mname = token go P.<?> "module name"

457 where

472 where

src/Language/PureScript/Pretty/Types.hs+42−27

@@ -3,7 +3,9 @@

3--

4module Language.PureScript.Pretty.Types

5 ( typeAsBox

6+ , suggestedTypeAsBox

6 , prettyPrintType

7 , prettyPrintType

8+ , prettyPrintSuggestedType

7 , typeAtomAsBox

9 , typeAtomAsBox

8 , prettyPrintTypeAtom

10 , prettyPrintTypeAtom

9 , prettyPrintRowWith

11 , prettyPrintRowWith

@@ -27,23 +29,6 @@ import Language.PureScript.Types

27

29

28import Text.PrettyPrint.Boxes hiding ((<+>))

30import Text.PrettyPrint.Boxes hiding ((<+>))

29

31

30−typeLiterals :: Pattern () Type Box

31−typeLiterals = mkPattern match

32− where

33− match TypeWildcard{} = Just $ text "_"

34− match (TypeVar var) = Just $ text var

35− match (TypeLevelString s) = Just . text $ show s

36− match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row

37− match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor

38− match (TUnknown u) = Just $ text $ 't' : show u

39− match (Skolem name s _ _) = Just $ text $ name ++ show s

40− match REmpty = Just $ text "()"

41− match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row

42− match (BinaryNoParensType op l r) =

43− Just $ typeAsBox l <> text " " <> typeAsBox op <> text " " <> typeAsBox r

44− match (TypeOp op) = Just $ text $ showQualified runOpName op

45− match _ = Nothing

46−

47constraintsAsBox :: [Constraint] -> Box -> Box

32constraintsAsBox :: [Constraint] -> Box -> Box

48constraintsAsBox [con] ty = text "(" <> constraintAsBox con `before` (text ") => " <> ty)

33constraintsAsBox [con] ty = text "(" <> constraintAsBox con `before` (text ") => " <> ty)

49constraintsAsBox xs ty = vcat left (zipWith (\i con -> text (if i == 0 then "( " else ", ") <> constraintAsBox con) [0 :: Int ..] xs) `before` (text ") => " <> ty)

34constraintsAsBox xs ty = vcat left (zipWith (\i con -> text (if i == 0 then "( " else ", ") <> constraintAsBox con) [0 :: Int ..] xs) `before` (text ") => " <> ty)

@@ -120,12 +105,32 @@ explicitParens = mkPattern match

120 match (ParensInType ty) = Just ((), ty)

105 match (ParensInType ty) = Just ((), ty)

121 match _ = Nothing

106 match _ = Nothing

122

107

123−matchTypeAtom :: Pattern () Type Box

108+matchTypeAtom :: Bool -> Pattern () Type Box

109+matchTypeAtom suggesting =

124−matchTypeAtom = typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) matchType

110+ typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) (matchType suggesting)

125−

126−matchType :: Pattern () Type Box

127−matchType = buildPrettyPrinter operators matchTypeAtom

128 where

111 where

112+ typeLiterals :: Pattern () Type Box

113+ typeLiterals = mkPattern match where

114+ match TypeWildcard{} = Just $ text "_"

115+ match (TypeVar var) = Just $ text var

116+ match (TypeLevelString s) = Just . text $ show s

117+ match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row

118+ match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor

119+ match (TUnknown u)

120+ | suggesting = Just $ text "_"

121+ | otherwise = Just $ text $ 't' : show u

122+ match (Skolem name s _ _)

123+ | suggesting = Just $ text name

124+ | otherwise = Just $ text $ name ++ show s

125+ match REmpty = Just $ text "()"

126+ match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row

127+ match (BinaryNoParensType op l r) =

128+ Just $ typeAsBox l <> text " " <> typeAsBox op <> text " " <> typeAsBox r

129+ match (TypeOp op) = Just $ text $ showQualified runOpName op

130+ match _ = Nothing

131+

132+matchType :: Bool -> Pattern () Type Box

133+matchType = buildPrettyPrinter operators . matchTypeAtom where

129 operators :: OperatorTable () Type Box

134 operators :: OperatorTable () Type Box

130 operators =

135 operators =

131 OperatorTable [ [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ]

136 OperatorTable [ [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ]

@@ -152,7 +157,7 @@ forall_ = mkPattern match

152typeAtomAsBox :: Type -> Box

157typeAtomAsBox :: Type -> Box

153typeAtomAsBox

158typeAtomAsBox

154 = fromMaybe (internalError "Incomplete pattern")

159 = fromMaybe (internalError "Incomplete pattern")

155− . PA.pattern matchTypeAtom ()

160+ . PA.pattern (matchTypeAtom False) ()

156 . insertPlaceholders

161 . insertPlaceholders

157

162

158-- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses

163-- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses

@@ -160,11 +165,21 @@ prettyPrintTypeAtom :: Type -> String

160prettyPrintTypeAtom = render . typeAtomAsBox

165prettyPrintTypeAtom = render . typeAtomAsBox

161

166

162typeAsBox :: Type -> Box

167typeAsBox :: Type -> Box

163−typeAsBox

168+typeAsBox = typeAsBoxImpl False

169+

170+suggestedTypeAsBox :: Type -> Box

171+suggestedTypeAsBox = typeAsBoxImpl True

172+

173+typeAsBoxImpl :: Bool -> Type -> Box

174+typeAsBoxImpl suggesting

164 = fromMaybe (internalError "Incomplete pattern")

175 = fromMaybe (internalError "Incomplete pattern")

165− . PA.pattern matchType ()

176+ . PA.pattern (matchType suggesting) ()

166 . insertPlaceholders

177 . insertPlaceholders

167

178

168−-- | Generate a pretty-printed string representing a Type

179+-- | Generate a pretty-printed string representing a 'Type'

169prettyPrintType :: Type -> String

180prettyPrintType :: Type -> String

170−prettyPrintType = render . typeAsBox

181+prettyPrintType = render . typeAsBoxImpl False

182+

183+-- | Generate a pretty-printed string representing a suggested 'Type'

184+prettyPrintSuggestedType :: Type -> String

185+prettyPrintSuggestedType = render . typeAsBoxImpl True

src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+194−11

@@ -13,7 +13,7 @@ import Control.Monad (replicateM)

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

14import Control.Monad.Supply.Class (MonadSupply)

15

16−import Data.List (foldl', find, sortBy)

16+import Data.List (foldl', find, sortBy, unzip5)

17import Data.Maybe (fromMaybe)

18import Data.Ord (comparing)

19

@@ -58,9 +58,14 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwr

58 | className == Qualified (Just dataNewtype) (ProperName "Newtype")

59 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy

60 , mn == fromMaybe mn mn'

61− = do

62− (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon args unwrappedTy

61+ = do (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon args unwrappedTy

63− return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst)

62+ return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst)

63+deriveInstance mn ds (TypeInstanceDeclaration nm deps className [actualTy, repTy] DerivedInstance)

64+ | className == Qualified (Just dataGenericRep) (ProperName C.generic)

65+ , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor actualTy

66+ , mn == fromMaybe mn mn'

67+ = do (inst, inferredRepTy) <- deriveGenericRep mn ds tyCon args repTy

68+ return $ TypeInstanceDeclaration nm deps className [actualTy, inferredRepTy] (ExplicitInstance inst)

64deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)

69deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)

65 = throwError . errorMessage $ CannotDerive className tys

70 = throwError . errorMessage $ CannotDerive className tys

66deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@(_ : _) NewtypeInstance)

71deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@(_ : _) NewtypeInstance)

@@ -122,6 +127,9 @@ deriveNewtypeInstance className ds tys tyConNm dargs = do

122dataGeneric :: ModuleName

127dataGeneric :: ModuleName

123dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]

128dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]

124

129

130+dataGenericRep :: ModuleName

131+dataGenericRep = ModuleName [ ProperName "Data", ProperName "Generic", ProperName "Rep" ]

132+

125dataMaybe :: ModuleName

133dataMaybe :: ModuleName

126dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]

134dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]

127

135

@@ -304,6 +312,187 @@ deriveGeneric mn ds tyConNm dargs = do

304 mkGenVar :: Ident -> Expr

312 mkGenVar :: Ident -> Expr

305 mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic]))

313 mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic]))

306

314

315+deriveGenericRep

316+ :: forall m

317+ . (MonadError MultipleErrors m, MonadSupply m)

318+ => ModuleName

319+ -> [Declaration]

320+ -> ProperName 'TypeName

321+ -> [Type]

322+ -> Type

323+ -> m ([Declaration], Type)

324+deriveGenericRep mn ds tyConNm tyConArgs repTy = do

325+ checkIsWildcard tyConNm repTy

326+ go =<< findTypeDecl tyConNm ds

327+ where

328+ go :: Declaration -> m ([Declaration], Type)

329+ go (DataDeclaration _ _ args dctors) = do

330+ x <- freshIdent "x"

331+ (reps, to, from) <- unzip3 <$> traverse makeInst dctors

332+ let rep = toRepTy reps

333+ inst | null reps =

334+ -- If there are no cases, spin

335+ [ ValueDeclaration (Ident "to") Public [] $ Right $

336+ lamCase x [ CaseAlternative [NullBinder]

337+ (Right (App toName (Var (Qualified Nothing x))))

338+ ]

339+ , ValueDeclaration (Ident "from") Public [] $ Right $

340+ lamCase x [ CaseAlternative [NullBinder]

341+ (Right (App fromName (Var (Qualified Nothing x))))

342+ ]

343+ ]

344+ | otherwise =

345+ [ ValueDeclaration (Ident "to") Public [] $ Right $

346+ lamCase x (zipWith ($) (map underBinder (sumBinders (length dctors))) to)

347+ , ValueDeclaration (Ident "from") Public [] $ Right $

348+ lamCase x (zipWith ($) (map underExpr (sumExprs (length dctors))) from)

349+ ]

350+

351+ subst = zipWith ((,) . fst) args tyConArgs

352+ return (inst, replaceAllTypeVars subst rep)

353+ go (PositionedDeclaration _ _ d) = go d

354+ go _ = internalError "deriveGenericRep go: expected DataDeclaration"

355+

356+ select :: (a -> a) -> (a -> a) -> Int -> [a -> a]

357+ select _ _ 0 = []

358+ select _ _ 1 = [id]

359+ select l r n = take (n - 1) (iterate (r .) l) ++ [compN (n - 1) r]

360+

361+ sumBinders :: Int -> [Binder -> Binder]

362+ sumBinders = select (ConstructorBinder inl . pure) (ConstructorBinder inr . pure)

363+

364+ sumExprs :: Int -> [Expr -> Expr]

365+ sumExprs = select (App (Constructor inl)) (App (Constructor inr))

366+

367+ compN :: Int -> (a -> a) -> a -> a

368+ compN 0 _ = id

369+ compN n f = f . compN (n - 1) f

370+

371+ makeInst

372+ :: (ProperName 'ConstructorName, [Type])

373+ -> m (Type, CaseAlternative, CaseAlternative)

374+ makeInst (ctorName, args) = do

375+ (ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args

376+ return ( TypeApp (TypeApp (TypeConstructor constructor)

377+ (TypeLevelString (runProperName ctorName)))

378+ ctorTy

379+ , CaseAlternative [ ConstructorBinder constructor [matchProduct] ]

380+ (Right (foldl App (Constructor (Qualified (Just mn) ctorName)) ctorArgs))

381+ , CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) matchCtor ]

382+ (Right (constructor' mkProduct))

383+ )

384+

385+ makeProduct

386+ :: [Type]

387+ -> m (Type, Binder, [Expr], [Binder], Expr)

388+ makeProduct [] =

389+ pure (noArgs, NullBinder, [], [], noArgs')

390+ makeProduct args = do

391+ (tys, bs1, es1, bs2, es2) <- unzip5 <$> traverse makeArg args

392+ pure ( foldr1 (\f -> TypeApp (TypeApp (TypeConstructor productName) f)) tys

393+ , foldr1 (\b1 b2 -> ConstructorBinder productName [b1, b2]) bs1

394+ , es1

395+ , bs2

396+ , foldr1 (\e1 -> App (App (Constructor productName) e1)) es2

397+ )

398+

399+ makeArg :: Type -> m (Type, Binder, Expr, Binder, Expr)

400+ makeArg arg | Just rec <- objectType arg = do

401+ let fields = decomposeRec rec

402+ fieldNames <- traverse freshIdent (map fst fields)

403+ pure ( TypeApp (TypeConstructor record)

404+ (foldr1 (\f -> TypeApp (TypeApp (TypeConstructor productName) f))

405+ (map (\(name, ty) ->

406+ TypeApp (TypeApp (TypeConstructor field) (TypeLevelString name)) ty) fields))

407+ , ConstructorBinder record

408+ [ foldr1 (\b1 b2 -> ConstructorBinder productName [b1, b2])

409+ (map (\ident -> ConstructorBinder field [VarBinder ident]) fieldNames)

410+ ]

411+ , Literal . ObjectLiteral $

412+ zipWith (\(name, _) ident -> (name, Var (Qualified Nothing ident))) fields fieldNames

413+ , LiteralBinder . ObjectLiteral $

414+ zipWith (\(name, _) ident -> (name, VarBinder ident)) fields fieldNames

415+ , record' $

416+ foldr1 (\e1 -> App (App (Constructor productName) e1))

417+ (map (field' . Var . Qualified Nothing) fieldNames)

418+ )

419+ makeArg arg = do

420+ argName <- freshIdent "arg"

421+ pure ( TypeApp (TypeConstructor argument) arg

422+ , ConstructorBinder argument [ VarBinder argName ]

423+ , Var (Qualified Nothing argName)

424+ , VarBinder argName

425+ , argument' (Var (Qualified Nothing argName))

426+ )

427+

428+ underBinder :: (Binder -> Binder) -> CaseAlternative -> CaseAlternative

429+ underBinder f (CaseAlternative bs e) = CaseAlternative (map f bs) e

430+

431+ underExpr :: (Expr -> Expr) -> CaseAlternative -> CaseAlternative

432+ underExpr f (CaseAlternative b (Right e)) = CaseAlternative b (Right (f e))

433+ underExpr _ _ = internalError "underExpr: expected Right"

434+

435+ toRepTy :: [Type] -> Type

436+ toRepTy [] = noCtors

437+ toRepTy [only] = only

438+ toRepTy ctors = foldr1 (\f -> TypeApp (TypeApp sumCtor f)) ctors

439+

440+ toName :: Expr

441+ toName = Var (Qualified (Just dataGenericRep) (Ident "to"))

442+

443+ fromName :: Expr

444+ fromName = Var (Qualified (Just dataGenericRep) (Ident "from"))

445+

446+ noCtors :: Type

447+ noCtors = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "NoConstructors"))

448+

449+ noArgs :: Type

450+ noArgs = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "NoArguments"))

451+

452+ noArgs' :: Expr

453+ noArgs' = Constructor (Qualified (Just dataGenericRep) (ProperName "NoArguments"))

454+

455+ sumCtor :: Type

456+ sumCtor = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "Sum"))

457+

458+ inl :: Qualified (ProperName 'ConstructorName)

459+ inl = Qualified (Just dataGenericRep) (ProperName "Inl")

460+

461+ inr :: Qualified (ProperName 'ConstructorName)

462+ inr = Qualified (Just dataGenericRep) (ProperName "Inr")

463+

464+ productName :: Qualified (ProperName ty)

465+ productName = Qualified (Just dataGenericRep) (ProperName "Product")

466+

467+ constructor :: Qualified (ProperName ty)

468+ constructor = Qualified (Just dataGenericRep) (ProperName "Constructor")

469+

470+ constructor' :: Expr -> Expr

471+ constructor' = App (Constructor constructor)

472+

473+ argument :: Qualified (ProperName ty)

474+ argument = Qualified (Just dataGenericRep) (ProperName "Argument")

475+

476+ argument' :: Expr -> Expr

477+ argument' = App (Constructor argument)

478+

479+ record :: Qualified (ProperName ty)

480+ record = Qualified (Just dataGenericRep) (ProperName "Rec")

481+

482+ record' :: Expr -> Expr

483+ record' = App (Constructor record)

484+

485+ field :: Qualified (ProperName ty)

486+ field = Qualified (Just dataGenericRep) (ProperName "Field")

487+

488+ field' :: Expr -> Expr

489+ field' = App (Constructor field)

490+

491+checkIsWildcard :: MonadError MultipleErrors m => ProperName 'TypeName -> Type -> m ()

492+checkIsWildcard _ (TypeWildcard _) = return ()

493+checkIsWildcard tyConNm _ =

494+ throwError . errorMessage $ ExpectedWildcard tyConNm

495+

307deriveEq ::

496deriveEq ::

308 forall m. (MonadError MultipleErrors m, MonadSupply m)

497 forall m. (MonadError MultipleErrors m, MonadSupply m)

309 => ModuleName

498 => ModuleName

@@ -451,7 +640,7 @@ deriveNewtype

451 -> Type

640 -> Type

452 -> m ([Declaration], Type)

641 -> m ([Declaration], Type)

453deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do

642deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do

454− checkIsWildcard unwrappedTy

643+ checkIsWildcard tyConNm unwrappedTy

455 go =<< findTypeDecl tyConNm ds

644 go =<< findTypeDecl tyConNm ds

456 where

645 where

457 go :: Declaration -> m ([Declaration], Type)

646 go :: Declaration -> m ([Declaration], Type)

@@ -477,12 +666,6 @@ deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do

477 go (PositionedDeclaration _ _ d) = go d

666 go (PositionedDeclaration _ _ d) = go d

478 go _ = internalError "deriveNewtype go: expected DataDeclaration"

667 go _ = internalError "deriveNewtype go: expected DataDeclaration"

479

668

480− checkIsWildcard :: Type -> m ()

481− checkIsWildcard (TypeWildcard _) =

482− return ()

483− checkIsWildcard _ =

484− throwError . errorMessage $ NonWildcardNewtypeInstance tyConNm

485−

486findTypeDecl

669findTypeDecl

487 :: (MonadError MultipleErrors m)

670 :: (MonadError MultipleErrors m)

488 => ProperName 'TypeName

671 => ProperName 'TypeName

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

@@ -11,7 +11,7 @@ module Language.PureScript.TypeChecker

11

12import Prelude.Compat

13

14−import Control.Monad (when, unless, void, forM, forM_)

14+import Control.Monad (when, unless, void, forM)

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

16import Control.Monad.State.Class (MonadState(..), modify)

17import Control.Monad.Supply.Class (MonadSupply)

@@ -279,7 +279,6 @@ typeCheckAll moduleName _ = traverse go

279 return d

280 go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do

281 traverse_ (checkTypeClassInstance moduleName) tys

282− forM_ deps $ traverse_ (checkTypeClassInstance moduleName) . constraintArgs

283 checkOrphanInstance dictName className tys

282 checkOrphanInstance dictName className tys

284 _ <- traverseTypeInstanceBody checkInstanceMembers body

283 _ <- traverseTypeInstanceBody checkInstanceMembers body

285 let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps)

284 let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps)

@@ -313,6 +312,7 @@ typeCheckAll moduleName _ = traverse go

313 where

312 where

314 checkType :: Type -> Bool

313 checkType :: Type -> Bool

315 checkType (TypeVar _) = False

314 checkType (TypeVar _) = False

315+ checkType (TypeLevelString _) = False

316 checkType (TypeConstructor (Qualified (Just mn'') _)) = moduleName == mn''

317 checkType (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance"

318 checkType (TypeApp t1 _) = checkType t1

src/Language/PureScript/TypeChecker/Entailment.hs+38−25

@@ -5,8 +5,10 @@

5--

6module Language.PureScript.TypeChecker.Entailment

7 ( InstanceContext

8+ , SolverOptions(..)

8 , replaceTypeClassDictionaries

9 , replaceTypeClassDictionaries

9 , newDictionaries

10 , newDictionaries

11+ , entails

10 ) where

12 ) where

11

13

12import Prelude.Compat

14import Prelude.Compat

@@ -56,7 +58,7 @@ replaceTypeClassDictionaries

56 . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)

58 . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)

57 => Bool

59 => Bool

58 -> Expr

60 -> Expr

59− -> m (Expr, [(Ident, Constraint)])

61+ -> m (Expr, [(Ident, InstanceContext, Constraint)])

60replaceTypeClassDictionaries shouldGeneralize expr = flip evalStateT M.empty $ do

62replaceTypeClassDictionaries shouldGeneralize expr = flip evalStateT M.empty $ do

61 -- Loop, deferring any unsolved constraints, until there are no more

63 -- Loop, deferring any unsolved constraints, until there are no more

62 -- constraints which can be solved, then make a generalization pass.

64 -- constraints which can be solved, then make a generalization pass.

@@ -70,18 +72,18 @@ replaceTypeClassDictionaries shouldGeneralize expr = flip evalStateT M.empty $ d

70 -- This pass solves constraints where possible, deferring constraints if not.

72 -- This pass solves constraints where possible, deferring constraints if not.

71 deferPass :: Expr -> StateT InstanceContext m (Expr, Any)

73 deferPass :: Expr -> StateT InstanceContext m (Expr, Any)

72 deferPass = fmap (second fst) . runWriterT . f where

74 deferPass = fmap (second fst) . runWriterT . f where

73− f :: Expr -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr

75+ f :: Expr -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr

74 (_, f, _) = everywhereOnValuesTopDownM return (go True) return

76 (_, f, _) = everywhereOnValuesTopDownM return (go True) return

75

77

76 -- This pass generalizes any remaining constraints

78 -- This pass generalizes any remaining constraints

77− generalizePass :: Expr -> StateT InstanceContext m (Expr, [(Ident, Constraint)])

79+ generalizePass :: Expr -> StateT InstanceContext m (Expr, [(Ident, InstanceContext, Constraint)])

78 generalizePass = fmap (second snd) . runWriterT . f where

80 generalizePass = fmap (second snd) . runWriterT . f where

79− f :: Expr -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr

81+ f :: Expr -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr

80 (_, f, _) = everywhereOnValuesTopDownM return (go False) return

82 (_, f, _) = everywhereOnValuesTopDownM return (go False) return

81

83

82− go :: Bool -> Expr -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr

84+ go :: Bool -> Expr -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr

83− go deferErrors dict@(TypeClassDictionary _ _ hints) =

85+ go deferErrors (TypeClassDictionary constraint context hints) =

84− rethrow (addHints hints) $ entails shouldGeneralize deferErrors dict

86+ rethrow (addHints hints) $ entails (SolverOptions shouldGeneralize deferErrors) constraint context hints

85 go _ other = return other

87 go _ other = return other

86

88

87-- | Three options for how we can handle a constraint, depending on the mode we're in.

89-- | Three options for how we can handle a constraint, depending on the mode we're in.

@@ -93,18 +95,29 @@ data EntailsResult a

93 | Deferred

95 | Deferred

94 -- ^ We couldn't solve this constraint right now, so it has been deferred

96 -- ^ We couldn't solve this constraint right now, so it has been deferred

95

97

96−-- |

98+-- | Options for the constraint solver

99+data SolverOptions = SolverOptions

100+ { solverShouldGeneralize :: Bool

101+ -- ^ Should the solver be allowed to generalize over unsolved constraints?

102+ , solverDeferErrors :: Bool

103+ -- ^ Should the solver be allowed to defer errors by skipping constraints?

104+ }

105+

97−-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,

106+-- | Check that the current set of type class dictionaries entail the specified type class goal, and, if so,

98-- return a type class dictionary reference.

107-- return a type class dictionary reference.

99−--

100entails

108entails

101 :: forall m

109 :: forall m

102 . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)

110 . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)

103− => Bool

111+ => SolverOptions

104− -> Bool

112+ -- ^ Solver options

105− -> Expr

113+ -> Constraint

114+ -- ^ The constraint to solve

115+ -> InstanceContext

116+ -- ^ The contexts in which to solve the constraint

117+ -> [ErrorMessageHint]

118+ -- ^ Error message hints to apply to any instance errors

106− -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr

119+ -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr

107−entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hints) =

120+entails SolverOptions{..} constraint context hints =

108 solve constraint

121 solve constraint

109 where

122 where

110 forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]

123 forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]

@@ -123,10 +136,10 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin

123 valUndefined :: Expr

136 valUndefined :: Expr

124 valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))

137 valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))

125

138

126− solve :: Constraint -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr

139+ solve :: Constraint -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr

127 solve con = go 0 con

140 solve con = go 0 con

128 where

141 where

129− go :: Int -> Constraint -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr

142+ go :: Int -> Constraint -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr

130 go work (Constraint className' tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'

143 go work (Constraint className' tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'

131 go work con'@(Constraint className' tys' conInfo) = WriterT . StateT . (withErrorMessageHint (ErrorSolvingConstraint con') .) . runStateT . runWriterT $ do

144 go work con'@(Constraint className' tys' conInfo) = WriterT . StateT . (withErrorMessageHint (ErrorSolvingConstraint con') .) . runStateT . runWriterT $ do

132 -- We might have unified types by solving other constraints, so we need to

145 -- We might have unified types by solving other constraints, so we need to

@@ -137,8 +150,10 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin

137 inferred <- lift get

150 inferred <- lift get

138 -- We need information about functional dependencies, so we have to look up the class

151 -- We need information about functional dependencies, so we have to look up the class

139 -- name in the environment:

152 -- name in the environment:

140− let findClass = fromMaybe (internalError "entails: type class not found in environment") . M.lookup className'

153+ classesInScope <- lift . lift $ gets (typeClasses . checkEnv)

141− TypeClassData{ typeClassDependencies } <- lift . lift $ gets (findClass . typeClasses . checkEnv)

154+ TypeClassData{ typeClassDependencies } <- case M.lookup className' classesInScope of

155+ Nothing -> throwError . errorMessage $ UnknownClass className'

156+ Just tcd -> pure tcd

142 let instances =

157 let instances =

143 [ (substs, tcd)

158 [ (substs, tcd)

144 | tcd <- forClassName (combineContexts context inferred) className' tys''

159 | tcd <- forClassName (combineContexts context inferred) className' tys''

@@ -179,7 +194,7 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin

179 let newContext = mkContext newDicts

194 let newContext = mkContext newDicts

180 modify (combineContexts newContext)

195 modify (combineContexts newContext)

181 -- Mark this constraint for generalization

196 -- Mark this constraint for generalization

182− tell (mempty, [(ident, unsolved)])

197+ tell (mempty, [(ident, context, unsolved)])

183 return (Var qident)

198 return (Var qident)

184 Deferred ->

199 Deferred ->

185 -- Constraint was deferred, just return the dictionary unchanged,

200 -- Constraint was deferred, just return the dictionary unchanged,

@@ -219,10 +234,10 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin

219

234

220 unique :: [Type] -> [(a, TypeClassDictionaryInScope)] -> m (EntailsResult a)

235 unique :: [Type] -> [(a, TypeClassDictionaryInScope)] -> m (EntailsResult a)

221 unique tyArgs []

236 unique tyArgs []

222− | deferErrors = return Deferred

237+ | solverDeferErrors = return Deferred

223 -- We need a special case for nullary type classes, since we want

238 -- We need a special case for nullary type classes, since we want

224 -- to generalize over Partial constraints.

239 -- to generalize over Partial constraints.

225− | shouldGeneralize && (null tyArgs || any canBeGeneralized tyArgs) = return (Unsolved (Constraint className' tyArgs conInfo))

240+ | solverShouldGeneralize && (null tyArgs || any canBeGeneralized tyArgs) = return (Unsolved (Constraint className' tyArgs conInfo))

226 | otherwise = throwError . errorMessage $ NoInstanceFound (Constraint className' tyArgs conInfo)

241 | otherwise = throwError . errorMessage $ NoInstanceFound (Constraint className' tyArgs conInfo)

227 unique _ [(a, dict)] = return $ Solved a dict

242 unique _ [(a, dict)] = return $ Solved a dict

228 unique tyArgs tcds

243 unique tyArgs tcds

@@ -233,7 +248,6 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin

233

248

234 canBeGeneralized :: Type -> Bool

249 canBeGeneralized :: Type -> Bool

235 canBeGeneralized TUnknown{} = True

250 canBeGeneralized TUnknown{} = True

236− canBeGeneralized Skolem{} = True

237 canBeGeneralized _ = False

251 canBeGeneralized _ = False

238

252

239 -- |

253 -- |

@@ -251,7 +265,7 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin

251 -- Create dictionaries for subgoals which still need to be solved by calling go recursively

265 -- Create dictionaries for subgoals which still need to be solved by calling go recursively

252 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type

266 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type

253 -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.

267 -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.

254− solveSubgoals :: Matching Type -> Maybe [Constraint] -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) (Maybe [Expr])

268+ solveSubgoals :: Matching Type -> Maybe [Constraint] -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) (Maybe [Expr])

255 solveSubgoals _ Nothing = return Nothing

269 solveSubgoals _ Nothing = return Nothing

256 solveSubgoals subst (Just subgoals) =

270 solveSubgoals subst (Just subgoals) =

257 Just <$> traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars (M.toList subst)))) subgoals

271 Just <$> traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars (M.toList subst)))) subgoals

@@ -268,7 +282,6 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin

268 App (Accessor (C.__superclass_ ++ showQualified runProperName superclassName ++ "_" ++ show index)

282 App (Accessor (C.__superclass_ ++ showQualified runProperName superclassName ++ "_" ++ show index)

269 dict)

283 dict)

270 valUndefined

284 valUndefined

271−entails _ _ _ = internalError "entails: expected TypeClassDictionary"

272

285

273-- Check if an instance matches our list of types, allowing for types

286-- Check if an instance matches our list of types, allowing for types

274-- to be solved via functional dependencies. If the types match, we return a

287-- to be solved via functional dependencies. If the types match, we return a

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

@@ -257,11 +257,11 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })

257

258-- | Run a computation in the typechecking monad, starting with an empty @Environment@

259runCheck :: (Functor m) => StateT CheckState m a -> m (a, Environment)

260−runCheck = runCheck' initEnvironment

260+runCheck = runCheck' (emptyCheckState initEnvironment)

261

262-- | Run a computation in the typechecking monad, failing with an error, or succeeding with a return value and the final @Environment@.

263−runCheck' :: (Functor m) => Environment -> StateT CheckState m a -> m (a, Environment)

263+runCheck' :: (Functor m) => CheckState -> StateT CheckState m a -> m (a, Environment)

264−runCheck' env check = second checkEnv <$> runStateT check (emptyCheckState env)

264+runCheck' st check = second checkEnv <$> runStateT check st

265

266-- | Make an assertion, failing with an error message

267guardWith :: (MonadError e m) => e -> Bool -> m ()

src/Language/PureScript/TypeChecker/Subsumption.hs+109−59

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

1−-- |

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE GADTs #-}

3+{-# LANGUAGE TypeFamilies #-}

4+

2−-- Subsumption checking

5+-- | Subsumption checking

3−--

4module Language.PureScript.TypeChecker.Subsumption

6module Language.PureScript.TypeChecker.Subsumption

5 ( subsumes

7 ( subsumes

6 ) where

8 ) where

@@ -25,72 +27,120 @@ import Language.PureScript.TypeChecker.Skolems

25import Language.PureScript.TypeChecker.Unify

27import Language.PureScript.TypeChecker.Unify

26import Language.PureScript.Types

28import Language.PureScript.Types

27

29

30+-- | Subsumption can operate in two modes:

31+--

32+-- * Elaboration mode, in which we try to insert type class dictionaries

33+-- * No-elaboration mode, in which we do not insert dictionaries

34+--

35+-- Some subsumption rules apply in both modes, and others are specific to

36+-- certain modes.

37+--

38+-- The subsumption algorithm follows the structure of the types in question,

39+-- and we can switch into no-elaboration mode when we move under a type

40+-- constructor where we can no longer insert dictionaries, e.g. into the fields

41+-- of a record.

42+data Mode = Elaborate | NoElaborate

43+

44+-- | Value-level proxies for the two modes

45+data ModeSing (mode :: Mode) where

46+ SElaborate :: ModeSing 'Elaborate

47+ SNoElaborate :: ModeSing 'NoElaborate

48+

49+-- | This type family tracks what evidence we return from 'subsumes' for each

50+-- mode.

51+type family Coercion (mode :: Mode) where

52+ -- When elaborating, we generate a coercion

53+ Coercion 'Elaborate = Expr -> Expr

54+ -- When we're not elaborating, we don't generate coercions

55+ Coercion 'NoElaborate = ()

56+

57+-- | The default coercion for each mode.

58+defaultCoercion :: ModeSing mode -> Coercion mode

59+defaultCoercion SElaborate = id

60+defaultCoercion SNoElaborate = ()

61+

28-- | Check that one type subsumes another, rethrowing errors to provide a better error message

62-- | Check that one type subsumes another, rethrowing errors to provide a better error message

63+subsumes

29−subsumes :: (MonadError MultipleErrors m, MonadState CheckState m) => Maybe Expr -> Type -> Type -> m (Maybe Expr)

64+ :: (MonadError MultipleErrors m, MonadState CheckState m)

65+ => Type

66+ -> Type

67+ -> m (Expr -> Expr)

68+subsumes ty1 ty2 =

30−subsumes val ty1 ty2 = withErrorMessageHint (ErrorInSubsumption ty1 ty2) $ subsumes' val ty1 ty2

69+ withErrorMessageHint (ErrorInSubsumption ty1 ty2) $

70+ subsumes' SElaborate ty1 ty2

31

71

32-- | Check that one type subsumes another

72-- | Check that one type subsumes another

73+subsumes'

33−subsumes' :: (MonadError MultipleErrors m, MonadState CheckState m) =>

74+ :: (MonadError MultipleErrors m, MonadState CheckState m)

34− Maybe Expr ->

75+ => ModeSing mode

35− Type ->

76+ -> Type

36− Type ->

77+ -> Type

37− m (Maybe Expr)

78+ -> m (Coercion mode)

38−subsumes' val (ForAll ident ty1 _) ty2 = do

79+subsumes' mode (ForAll ident ty1 _) ty2 = do

39 replaced <- replaceVarWithUnknown ident ty1

80 replaced <- replaceVarWithUnknown ident ty1

40− subsumes val replaced ty2

81+ subsumes' mode replaced ty2

41−subsumes' val ty1 (ForAll ident ty2 sco) =

82+subsumes' mode ty1 (ForAll ident ty2 sco) =

42 case sco of

83 case sco of

43 Just sco' -> do

84 Just sco' -> do

44 sko <- newSkolemConstant

85 sko <- newSkolemConstant

45 let sk = skolemize ident sko sco' Nothing ty2

86 let sk = skolemize ident sko sco' Nothing ty2

46− subsumes val ty1 sk

87+ subsumes' mode ty1 sk

47 Nothing -> internalError "subsumes: unspecified skolem scope"

88 Nothing -> internalError "subsumes: unspecified skolem scope"

48−subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do

89+subsumes' mode (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do

49− _ <- subsumes Nothing arg2 arg1

90+ subsumes' SNoElaborate arg2 arg1

50− _ <- subsumes Nothing ret1 ret2

91+ subsumes' SNoElaborate ret1 ret2

51− return val

92+ -- Nothing was elaborated, return the default coercion

93+ return (defaultCoercion mode)

52−subsumes' val (KindedType ty1 _) ty2 =

94+subsumes' mode (KindedType ty1 _) ty2 =

53− subsumes val ty1 ty2

95+ subsumes' mode ty1 ty2

54−subsumes' val ty1 (KindedType ty2 _) =

96+subsumes' mode ty1 (KindedType ty2 _) =

55− subsumes val ty1 ty2

97+ subsumes' mode ty1 ty2

98+-- Only check subsumption for constrained types when elaborating.

99+-- Otherwise fall back to unification.

56−subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do

100+subsumes' SElaborate (ConstrainedType constraints ty1) ty2 = do

57 dicts <- getTypeClassDictionaries

101 dicts <- getTypeClassDictionaries

58 hints <- gets checkHints

102 hints <- gets checkHints

103+ elaborate <- subsumes' SElaborate ty1 ty2

59− subsumes' (Just $ foldl App val (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) ty1 ty2

104+ let addDicts val = foldl App val (map (\cs -> TypeClassDictionary cs dicts hints) constraints)

105+ return (elaborate . addDicts)

60−subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyRecord && f2 == tyRecord = do

106+subsumes' mode (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyRecord && f2 == tyRecord = do

61− let

107+ let

62− (ts1, r1') = rowToList r1

108+ (ts1, r1') = rowToList r1

63− (ts2, r2') = rowToList r2

109+ (ts2, r2') = rowToList r2

64− ts1' = sortBy (comparing fst) ts1

110+ ts1' = sortBy (comparing fst) ts1

65− ts2' = sortBy (comparing fst) ts2

111+ ts2' = sortBy (comparing fst) ts2

66− -- For { ts1 | r1 } to subsume { ts2 | r2 } when r1 is empty (= we're working with a closed row),

112+ -- For { ts1 | r1 } to subsume { ts2 | r2 } when r1 is empty (= we're working with a closed row),

67− -- every property in ts2 must appear in ts1. If not, then the candidate expression is missing a required property.

113+ -- every property in ts2 must appear in ts1. If not, then the candidate expression is missing a required property.

68− -- Conversely, when r2 is empty, every property in ts1 must appear in ts2, or else the expression has

114+ -- Conversely, when r2 is empty, every property in ts1 must appear in ts2, or else the expression has

69− -- an additional property which is not allowed.

115+ -- an additional property which is not allowed.

70− when (r1' == REmpty)

116+ when (r1' == REmpty)

71− (for_ (firstMissingProp ts2' ts1') (throwError . errorMessage . PropertyIsMissing . fst))

117+ (for_ (firstMissingProp ts2' ts1') (throwError . errorMessage . PropertyIsMissing . fst))

72− when (r2' == REmpty)

118+ when (r2' == REmpty)

73− (for_ (firstMissingProp ts1' ts2') (throwError . errorMessage . AdditionalProperty . fst))

119+ (for_ (firstMissingProp ts1' ts2') (throwError . errorMessage . AdditionalProperty . fst))

74− go ts1' ts2' r1' r2'

120+ go ts1' ts2' r1' r2'

75− return val

121+ -- Nothing was elaborated, return the default coercion

122+ return (defaultCoercion mode)

76 where

123 where

77− go [] ts2 r1' r2' = unifyTypes r1' (rowFromList (ts2, r2'))

124+ go [] ts2 r1' r2' = unifyTypes r1' (rowFromList (ts2, r2'))

78− go ts1 [] r1' r2' = unifyTypes r2' (rowFromList (ts1, r1'))

125+ go ts1 [] r1' r2' = unifyTypes r2' (rowFromList (ts1, r1'))

79− go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1' r2'

126+ go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1' r2'

80− | p1 == p2 = do _ <- subsumes Nothing ty1 ty2

127+ | p1 == p2 = do subsumes' SNoElaborate ty1 ty2

81− go ts1 ts2 r1' r2'

128+ go ts1 ts2 r1' r2'

82− | p1 < p2 = do rest <- freshType

129+ | p1 < p2 = do rest <- freshType

83− -- What happens next is a bit of a hack.

130+ -- What happens next is a bit of a hack.

84− -- TODO: in the new type checker, object properties will probably be restricted to being monotypes

131+ -- TODO: in the new type checker, object properties will probably be restricted to being monotypes

85− -- in which case, this branch of the subsumes function should not even be necessary.

132+ -- in which case, this branch of the subsumes function should not even be necessary.

86− unifyTypes r2' (RCons p1 ty1 rest)

133+ unifyTypes r2' (RCons p1 ty1 rest)

87− go ts1 ((p2, ty2) : ts2) r1' rest

134+ go ts1 ((p2, ty2) : ts2) r1' rest

88− | otherwise = do rest <- freshType

135+ | otherwise = do rest <- freshType

89− unifyTypes r1' (RCons p2 ty2 rest)

136+ unifyTypes r1' (RCons p2 ty2 rest)

90− go ((p1, ty1) : ts1) ts2 rest r2'

137+ go ((p1, ty1) : ts1) ts2 rest r2'

138+

91− -- Find the first property that's in the first list (of tuples) but not in the second

139+ -- Find the first property that's in the first list (of tuples) but not in the second

92− firstMissingProp t1 t2 = fst <$> uncons (minusBy' (comparing fst) t1 t2)

140+ firstMissingProp t1 t2 = fst <$> uncons (minusBy' (comparing fst) t1 t2)

93−subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyRecord = subsumes val ty2 ty1

141+subsumes' mode ty1 ty2@(TypeApp obj _) | obj == tyRecord =

142+ subsumes' mode ty2 ty1

94−subsumes' val ty1 ty2 = do

143+subsumes' mode ty1 ty2 = do

95 unifyTypes ty1 ty2

144 unifyTypes ty1 ty2

96− return val

145+ -- Nothing was elaborated, return the default coercion

146+ return (defaultCoercion mode)

src/Language/PureScript/TypeChecker/TypeSearch.hsnew file+94

@@ -0,0 +1,94 @@

1+{-# LANGUAGE NoImplicitPrelude #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE RecordWildCards #-}

4+

5+module Language.PureScript.TypeChecker.TypeSearch

6+ ( typeSearch

7+ ) where

8+

9+import Protolude

10+

11+import Control.Monad.Writer

12+import qualified Data.Map as Map

13+import qualified Language.PureScript.TypeChecker.Entailment as Entailment

14+

15+import qualified Language.PureScript.TypeChecker.Monad as TC

16+import Language.PureScript.TypeChecker.Subsumption

17+import Language.PureScript.TypeChecker.Unify as P

18+

19+import Control.Monad.Supply as P

20+import Language.PureScript.AST as P

21+import Language.PureScript.Environment as P

22+import Language.PureScript.Errors as P

23+import Language.PureScript.Names as P

24+import Language.PureScript.TypeChecker.Skolems as Skolem

25+import Language.PureScript.TypeChecker.Synonyms as P

26+import Language.PureScript.Types as P

27+

28+checkInEnvironment

29+ :: Environment

30+ -> TC.CheckState

31+ -> StateT TC.CheckState (SupplyT (WriterT b (Except P.MultipleErrors))) a

32+ -> Maybe (a, Environment)

33+checkInEnvironment env st =

34+ either (const Nothing) Just

35+ . runExcept

36+ . evalWriterT

37+ . P.evalSupplyT 0

38+ . TC.runCheck' (st { TC.checkEnv = env })

39+

40+evalWriterT :: Monad m => WriterT b m r -> m r

41+evalWriterT m = liftM fst (runWriterT m)

42+

43+checkSubsume

44+ :: Maybe [(P.Ident, Entailment.InstanceContext, P.Constraint)]

45+ -- ^ Additional constraints we need to satisfy

46+ -> P.Environment

47+ -- ^ The Environment which contains the relevant definitions and typeclasses

48+ -> TC.CheckState

49+ -- ^ The typechecker state

50+ -> P.Type

51+ -- ^ The user supplied type

52+ -> P.Type

53+ -- ^ The type supplied by the environment

54+ -> Maybe ((P.Expr, [(P.Ident, Entailment.InstanceContext, P.Constraint)]), P.Environment)

55+checkSubsume unsolved env st userT envT = checkInEnvironment env st $ do

56+ let initializeSkolems =

57+ Skolem.introduceSkolemScope

58+ <=< P.replaceAllTypeSynonyms

59+ <=< P.replaceTypeWildcards

60+

61+ userT' <- initializeSkolems userT

62+ envT' <- initializeSkolems envT

63+

64+ let dummyExpression = P.Var (P.Qualified Nothing (P.Ident "x"))

65+

66+ elab <- subsumes envT' userT'

67+ subst <- gets TC.checkSubstitution

68+ let expP = P.overTypes (P.substituteType subst) (elab dummyExpression)

69+

70+ -- Now check that any unsolved constraints have not become impossible

71+ (traverse_ . traverse_) (\(_, context, constraint) -> do

72+ let constraint' = P.mapConstraintArgs (map (P.substituteType subst)) constraint

73+ flip evalStateT Map.empty . evalWriterT $

74+ Entailment.entails

75+ (Entailment.SolverOptions

76+ { solverShouldGeneralize = True

77+ , solverDeferErrors = False

78+ }) constraint' context []) unsolved

79+

80+ -- Finally, check any constraints which were found during elaboration

81+ Entailment.replaceTypeClassDictionaries (isJust unsolved) expP

82+

83+typeSearch

84+ :: Maybe [(P.Ident, Entailment.InstanceContext, P.Constraint)]

85+ -- ^ Additional constraints we need to satisfy

86+ -> P.Environment

87+ -- ^ The Environment which contains the relevant definitions and typeclasses

88+ -> TC.CheckState

89+ -- ^ The typechecker state

90+ -> P.Type

91+ -- ^ The type we are looking for

92+ -> Map (P.Qualified P.Ident) P.Type

93+typeSearch unsolved env st type' =

94+ Map.mapMaybe (\(x, _, _) -> checkSubsume unsolved env st type' x $> x) (P.names env)

src/Language/PureScript/TypeChecker/Types.hs+62−48

@@ -1,3 +1,4 @@

1+{-# LANGUAGE LambdaCase #-}

1{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE NamedFieldPuns #-}

3{-# LANGUAGE NamedFieldPuns #-}

3

4

@@ -27,13 +28,16 @@ module Language.PureScript.TypeChecker.Types

27

28

28import Prelude.Compat

29import Prelude.Compat

29

30

31+import Control.Arrow (first, second, (***))

30import Control.Monad

32import Control.Monad

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

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

32import Control.Monad.State.Class (MonadState(..), gets)

34import Control.Monad.State.Class (MonadState(..), gets)

33import Control.Monad.Supply.Class (MonadSupply)

35import Control.Monad.Supply.Class (MonadSupply)

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

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

35

37

38+import Data.Bifunctor (bimap)

36import Data.Either (lefts, rights)

39import Data.Either (lefts, rights)

40+import Data.Functor (($>))

37import Data.List (transpose, nub, (\\), partition, delete)

41import Data.List (transpose, nub, (\\), partition, delete)

38import Data.Maybe (fromMaybe)

42import Data.Maybe (fromMaybe)

39import qualified Data.Map as M

43import qualified Data.Map as M

@@ -53,9 +57,11 @@ import Language.PureScript.TypeChecker.Rows

53import Language.PureScript.TypeChecker.Skolems

57import Language.PureScript.TypeChecker.Skolems

54import Language.PureScript.TypeChecker.Subsumption

58import Language.PureScript.TypeChecker.Subsumption

55import Language.PureScript.TypeChecker.Synonyms

59import Language.PureScript.TypeChecker.Synonyms

60+import Language.PureScript.TypeChecker.TypeSearch

56import Language.PureScript.TypeChecker.Unify

61import Language.PureScript.TypeChecker.Unify

57import Language.PureScript.Types

62import Language.PureScript.Types

58

63

64+

59data BindingGroupType

65data BindingGroupType

60 = RecursiveBindingGroup

66 = RecursiveBindingGroup

61 | NonRecursiveBindingGroup

67 | NonRecursiveBindingGroup

@@ -70,13 +76,13 @@ typesOf

70 -> [(Ident, Expr)]

76 -> [(Ident, Expr)]

71 -> m [(Ident, (Expr, Type))]

77 -> m [(Ident, (Expr, Type))]

72typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do

78typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do

73− (tys, w) <- withoutWarnings . capturingSubstitution tidyUp $ do

79+ tys <- capturingSubstitution tidyUp $ do

74 (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup (Just moduleName) vals

80 (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup (Just moduleName) vals

75− ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict

81+ ds1 <- parU typed $ \e -> withoutWarnings $ checkTypedBindingGroupElement moduleName e dict

76− ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict

82+ ds2 <- forM untyped $ \e -> withoutWarnings $ typeForBindingGroupElement e dict untypedDict

77− return (map (\x -> (False, x)) ds1 ++ map (\x -> (True, x)) ds2)

83+ return (map (False, ) ds1 ++ map (True, ) ds2)

78

84

79− inferred <- forM tys $ \(shouldGeneralize, (ident, (val, ty))) -> do

85+ inferred <- forM tys $ \(shouldGeneralize, ((ident, (val, ty)), _)) -> do

80 -- Replace type class dictionary placeholders with actual dictionaries

86 -- Replace type class dictionary placeholders with actual dictionaries

81 (val', unsolved) <- replaceTypeClassDictionaries shouldGeneralize val

87 (val', unsolved) <- replaceTypeClassDictionaries shouldGeneralize val

82 -- Generalize and constrain the type

88 -- Generalize and constrain the type

@@ -96,7 +102,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do

96 $ CannotGeneralizeRecursiveFunction ident generalized

102 $ CannotGeneralizeRecursiveFunction ident generalized

97 -- Make sure any unsolved type constraints only use type variables which appear

103 -- Make sure any unsolved type constraints only use type variables which appear

98 -- unknown in the inferred type.

104 -- unknown in the inferred type.

99− forM_ unsolved $ \(_, con) -> do

105+ forM_ unsolved $ \(_, _, con) -> do

100 -- We need information about functional dependencies, since we allow

106 -- We need information about functional dependencies, since we allow

101 -- ambiguous types to be inferred if they can be solved by some functional

107 -- ambiguous types to be inferred if they can be solved by some functional

102 -- dependency.

108 -- dependency.

@@ -104,33 +110,56 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do

104 TypeClassData{ typeClassDependencies } <- gets (findClass . typeClasses . checkEnv)

110 TypeClassData{ typeClassDependencies } <- gets (findClass . typeClasses . checkEnv)

105 let solved = foldMap (S.fromList . fdDetermined) typeClassDependencies

111 let solved = foldMap (S.fromList . fdDetermined) typeClassDependencies

106 let constraintTypeVars = nub . foldMap (unknownsInType . fst) . filter ((`notElem` solved) . snd) $ zip (constraintArgs con) [0..]

112 let constraintTypeVars = nub . foldMap (unknownsInType . fst) . filter ((`notElem` solved) . snd) $ zip (constraintArgs con) [0..]

107− when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $

113+ when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $ do

108− throwError . onErrorMessages (replaceTypes currentSubst) . errorMessage $ NoInstanceFound con

114+ throwError . onErrorMessages (replaceTypes currentSubst) . errorMessage $ AmbiguousTypeVariables generalized con

109

115

110 -- Check skolem variables did not escape their scope

116 -- Check skolem variables did not escape their scope

111 skolemEscapeCheck val'

117 skolemEscapeCheck val'

112 -- Check rows do not contain duplicate labels

118 -- Check rows do not contain duplicate labels

113 checkDuplicateLabels val'

119 checkDuplicateLabels val'

114− return (ident, (foldr (Abs . Left . fst) val' unsolved, generalized))

120+ return ((ident, (foldr (Abs . Left . (\(x, _, _) -> x)) val' unsolved, generalized)), unsolved)

115

121

116 -- Show warnings here, since types in wildcards might have been solved during

122 -- Show warnings here, since types in wildcards might have been solved during

117 -- instance resolution (by functional dependencies).

123 -- instance resolution (by functional dependencies).

124+ finalState <- get

125+ forM_ tys $ \(shouldGeneralize, ((_, (_, _)), w)) -> do

118− finalSubst <- gets checkSubstitution

126+ let replaceTypes' = replaceTypes (checkSubstitution finalState)

127+ runTypeSearch' = runTypeSearch (guard shouldGeneralize $> foldMap snd inferred) finalState

119− escalateWarningWhen isHoleError . tell . onErrorMessages (replaceTypes finalSubst) $ w

128+ (escalateWarningWhen isHoleError . tell . onErrorMessages (runTypeSearch' . replaceTypes')) w

120

129

121− return inferred

130+ return (map fst inferred)

122 where

131 where

132+ replaceTypes

133+ :: Substitution

134+ -> ErrorMessage

135+ -> ErrorMessage

123 replaceTypes subst = onTypesInErrorMessage (substituteType subst)

136 replaceTypes subst = onTypesInErrorMessage (substituteType subst)

124

137

138+ -- | Run type search to complete any typed hole error messages

139+ runTypeSearch

140+ :: Maybe [(Ident, InstanceContext, Constraint)]

141+ -- ^ Any unsolved constraints which we need to continue to satisfy

142+ -> CheckState

143+ -- ^ The final type checker state

144+ -> ErrorMessage

145+ -> ErrorMessage

146+ runTypeSearch cons st = \case

147+ ErrorMessage hints (HoleInferredType x ty y (TSBefore env)) ->

148+ let subst = checkSubstitution st

149+ searchResult = (fmap . fmap) (substituteType subst)

150+ (M.toList (typeSearch cons env st (substituteType subst ty)))

151+ in ErrorMessage hints (HoleInferredType x ty y (TSAfter searchResult))

152+ other -> other

153+

125 -- | Generalize type vars using forall and add inferred constraints

154 -- | Generalize type vars using forall and add inferred constraints

126 generalize unsolved = varIfUnknown . constrain unsolved

155 generalize unsolved = varIfUnknown . constrain unsolved

127

156

128 -- | Add any unsolved constraints

157 -- | Add any unsolved constraints

129 constrain [] = id

158 constrain [] = id

130− constrain cs = ConstrainedType (map snd cs)

159+ constrain cs = ConstrainedType (map (\(_, _, x) -> x) cs)

131

160

132 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values

161 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values

133− tidyUp ts sub = map (\(b, (i, (val, ty))) -> (b, (i, (overTypes (substituteType sub) val, substituteType sub ty)))) ts

162+ tidyUp ts sub = map (second (first (second (overTypes (substituteType sub) *** substituteType sub)))) ts

134

163

135 isHoleError :: ErrorMessage -> Bool

164 isHoleError :: ErrorMessage -> Bool

136 isHoleError (ErrorMessage _ HoleInferredType{}) = True

165 isHoleError (ErrorMessage _ HoleInferredType{}) = True

@@ -199,19 +228,12 @@ typeForBindingGroupElement (ident, val) dict untypedDict = do

199-- | Check if a value contains a type annotation

228-- | Check if a value contains a type annotation

200isTyped :: (Ident, Expr) -> Either (Ident, Expr) (Ident, (Expr, Type, Bool))

229isTyped :: (Ident, Expr) -> Either (Ident, Expr) (Ident, (Expr, Type, Bool))

201isTyped (name, TypedValue checkType value ty) = Right (name, (value, ty, checkType))

230isTyped (name, TypedValue checkType value ty) = Right (name, (value, ty, checkType))

231+isTyped (name, PositionedValue pos c value) =

232+ bimap (second (PositionedValue pos c))

233+ (second (\(e, t, b) -> (PositionedValue pos c e, t, b)))

234+ (isTyped (name, value))

202isTyped (name, value) = Left (name, value)

235isTyped (name, value) = Left (name, value)

203

236

204−-- |

205−-- Map a function over type annotations appearing inside a value

206−--

207−overTypes :: (Type -> Type) -> Expr -> Expr

208−overTypes f = let (_, f', _) = everywhereOnValues id g id in f'

209− where

210− g :: Expr -> Expr

211− g (TypedValue checkTy val t) = TypedValue checkTy val (f t)

212− g (TypeClassDictionary c sco hints) = TypeClassDictionary (mapConstraintArgs (map f) c) sco hints

213− g other = other

214−

215-- | Check the kind of a type, failing if it is not of kind *.

237-- | Check the kind of a type, failing if it is not of kind *.

216checkTypeKind ::

238checkTypeKind ::

217 (MonadError MultipleErrors m) =>

239 (MonadError MultipleErrors m) =>

@@ -339,7 +361,8 @@ infer' (TypedValue checkType val ty) = do

339infer' (Hole name) = do

361infer' (Hole name) = do

340 ty <- freshType

362 ty <- freshType

341 ctx <- getLocalContext

363 ctx <- getLocalContext

364+ env <- getEnv

342− tell . errorMessage $ HoleInferredType name ty ctx

365+ tell . errorMessage $ HoleInferredType name ty ctx (TSBefore env)

343 return $ TypedValue True (Hole name) ty

366 return $ TypedValue True (Hole name) ty

344infer' (PositionedValue pos c val) = warnAndRethrowWithPositionTC pos $ do

367infer' (PositionedValue pos c val) = warnAndRethrowWithPositionTC pos $ do

345 TypedValue t v ty <- infer' val

368 TypedValue t v ty <- infer' val

@@ -568,18 +591,14 @@ check' (Abs (Right _) _) _ = internalError "Binder was not desugared"

568check' (App f arg) ret = do

591check' (App f arg) ret = do

569 f'@(TypedValue _ _ ft) <- infer f

592 f'@(TypedValue _ _ ft) <- infer f

570 (retTy, app) <- checkFunctionApplication f' ft arg

593 (retTy, app) <- checkFunctionApplication f' ft arg

571− v' <- subsumes (Just app) retTy ret

594+ elaborate <- subsumes retTy ret

572− case v' of

573− Nothing -> internalError "check: unable to check the subsumes relation."

574− Just app' -> return $ TypedValue True app' ret

595+ return $ TypedValue True (elaborate app) ret

575check' v@(Var var) ty = do

596check' v@(Var var) ty = do

576 checkVisibility var

597 checkVisibility var

577 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable $ var

598 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable $ var

578 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

599 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

579− v' <- subsumes (Just v) repl ty'

600+ elaborate <- subsumes repl ty'

580− case v' of

581− Nothing -> internalError "check: unable to check the subsumes relation."

582− Just v'' -> return $ TypedValue True v'' ty'

601+ return $ TypedValue True (elaborate v) ty'

583check' (DeferredDictionary className tys) _ = do

602check' (DeferredDictionary className tys) _ = do

584 {-

603 {-

585 -- Here, we replace a placeholder for a superclass dictionary with a regular

604 -- Here, we replace a placeholder for a superclass dictionary with a regular

@@ -596,12 +615,11 @@ check' (TypedValue checkType val ty1) ty2 = do

596 checkTypeKind ty1 kind

615 checkTypeKind ty1 kind

597 ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty1

616 ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty1

598 ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2

617 ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2

599− val' <- subsumes (Just val) ty1' ty2'

618+ _ <- subsumes ty1' ty2'

600− case val' of

619+ val' <- if checkType

601− Nothing -> internalError "check: unable to check the subsumes relation."

602− Just _ -> do

603− val''' <- if checkType then withScopedTypeVars moduleName args (check val ty2') else return val

620+ then withScopedTypeVars moduleName args (check val ty2')

621+ else return val

604− return $ TypedValue checkType val''' ty2'

622+ return $ TypedValue checkType val' ty2'

605check' (Case vals binders) ret = do

623check' (Case vals binders) ret = do

606 (vals', ts) <- instantiateForBinders vals binders

624 (vals', ts) <- instantiateForBinders vals binders

607 binders' <- checkBinders ts ret binders

625 binders' <- checkBinders ts ret binders

@@ -638,10 +656,8 @@ check' v@(Constructor c) ty = do

638 Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c

656 Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c

639 Just (_, _, ty1, _) -> do

657 Just (_, _, ty1, _) -> do

640 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

658 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

641− mv <- subsumes (Just v) repl ty

659+ elaborate <- subsumes repl ty

642− case mv of

643− Nothing -> internalError "check: unable to check the subsumes relation."

644− Just v' -> return $ TypedValue True v' ty

660+ return $ TypedValue True (elaborate v) ty

645check' (Let ds val) ty = do

661check' (Let ds val) ty = do

646 (ds', val') <- inferLetBinding [] ds val (`check` ty)

662 (ds', val') <- inferLetBinding [] ds val (`check` ty)

647 return $ TypedValue True (Let ds' val') ty

663 return $ TypedValue True (Let ds' val') ty

@@ -654,10 +670,8 @@ check' (PositionedValue pos c val) ty = warnAndRethrowWithPositionTC pos $ do

654 return $ TypedValue t (PositionedValue pos c v) ty'

670 return $ TypedValue t (PositionedValue pos c v) ty'

655check' val ty = do

671check' val ty = do

656 TypedValue _ val' ty' <- infer val

672 TypedValue _ val' ty' <- infer val

657− mt <- subsumes (Just val') ty' ty

673+ elaborate <- subsumes ty' ty

658− case mt of

659− Nothing -> internalError "check: unable to check the subsumes relation."

660− Just v' -> return $ TypedValue True v' ty

674+ return $ TypedValue True (elaborate val') ty

661

675

662-- |

676-- |

663-- Check the type of a collection of named record fields

677-- Check the type of a collection of named record fields

src/System/IO/UTF8.hs+12−2

@@ -4,11 +4,21 @@ import Prelude.Compat

4

5import qualified Data.ByteString as BS

6import qualified Data.ByteString.UTF8 as UTF8

7+import Data.Text (Text)

8+import qualified Data.Text.Encoding as TE

9+

10+readUTF8FileT :: FilePath -> IO Text

11+readUTF8FileT inFile =

12+ fmap TE.decodeUtf8 (BS.readFile inFile)

13+

14+writeUTF8FileT :: FilePath -> Text -> IO ()

15+writeUTF8FileT inFile text =

16+ BS.writeFile inFile (TE.encodeUtf8 text)

7

17

8readUTF8File :: FilePath -> IO String

18readUTF8File :: FilePath -> IO String

9−readUTF8File inFile = do

19+readUTF8File inFile =

10 fmap UTF8.toString (BS.readFile inFile)

20 fmap UTF8.toString (BS.readFile inFile)

11

21

12writeUTF8File :: FilePath -> String -> IO ()

22writeUTF8File :: FilePath -> String -> IO ()

13−writeUTF8File inFile text = do

23+writeUTF8File inFile text =

14 BS.writeFile inFile (UTF8.fromString text)

24 BS.writeFile inFile (UTF8.fromString text)

stack.yaml+1−10

@@ -1,12 +1,3 @@

1−resolver: lts-6.13

1+resolver: lts-6.10

2packages:

3- '.'

4−extra-deps:

5−# - aeson-1.0.0.0

6−- http-client-0.5.1

7−- http-client-tls-0.3.0

8−- pipes-http-1.0.4

9−# - semigroups-0.18.2

10−# flags:

11−# semigroups:

12−# bytestring-builder: false

tests/Language/PureScript/Ide/FilterSpec.hs+1−1

@@ -9,7 +9,7 @@ import qualified Language.PureScript as P

9import Test.Hspec

10

11value :: Text -> IdeDeclarationAnn

12−value s = IdeDeclarationAnn emptyAnn (IdeValue (P.Ident (toS s)) P.REmpty)

12+value s = IdeDeclarationAnn emptyAnn (IdeDeclValue (IdeValue (P.Ident (toS s)) P.REmpty))

13

14moduleA, moduleB :: Module

15moduleA = (P.moduleNameFromString "Module.A", [value "function1"])

tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs+4−4

@@ -6,12 +6,12 @@ module Language.PureScript.Ide.Imports.IntegrationSpec where

6import Protolude

7

8import qualified Data.Text as T

9−import qualified Data.Text.IO as TIO

10import qualified Language.PureScript.Ide.Integration as Integration

9import qualified Language.PureScript.Ide.Integration as Integration

11import Test.Hspec

10import Test.Hspec

12

11

13import System.Directory

12import System.Directory

14import System.FilePath

13import System.FilePath

14+import System.IO.UTF8 (readUTF8FileT)

15

16setup :: IO ()

17setup = void (Integration.reset *> Integration.loadAll)

@@ -27,7 +27,7 @@ withSupportFiles test = do

27outputFileShouldBe :: [Text] -> IO ()

28outputFileShouldBe expectation = do

29 outFp <- (</> "src" </> "ImportsSpecOut.tmp") <$> Integration.projectDirectory

30− outRes <- TIO.readFile outFp

30+ outRes <- readUTF8FileT outFp

31 shouldBe (T.lines outRes) expectation

32

33spec :: Spec

@@ -57,10 +57,10 @@ spec = beforeAll_ setup . describe "Adding imports" $ do

57 outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (class ATypeClass)"])

58 it "adds an explicit unqualified import (dataconstructor)" $ do

59 withSupportFiles (Integration.addImport "MyJust")

60− outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyMaybe(MyJust))"])

60+ outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyMaybe(..))"])

61 it "adds an explicit unqualified import (newtype)" $ do

62 withSupportFiles (Integration.addImport "MyNewtype")

63− outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyNewtype(MyNewtype))"])

63+ outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyNewtype(..))"])

64 it "adds an explicit unqualified import (typeclass member function)" $ do

65 withSupportFiles (Integration.addImport "typeClassFun")

66 outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (typeClassFun)"])

tests/Language/PureScript/Ide/ImportsSpec.hs+49−6

@@ -68,11 +68,13 @@ spec = do

68 describe "import commands" $ do

69 let simpleFileImports = let (_, _, i, _) = splitSimpleFile in i

70 addValueImport i mn is =

71− prettyPrintImportSection (addExplicitImport' (IdeValue (P.Ident i) wildcard) mn is)

71+ prettyPrintImportSection (addExplicitImport' (IdeDeclValue (IdeValue (P.Ident i) wildcard)) mn is)

72 addOpImport op mn is =

73− prettyPrintImportSection (addExplicitImport' (IdeValueOperator op (P.Qualified Nothing (Left (P.Ident ""))) 2 P.Infix Nothing) mn is)

73+ prettyPrintImportSection (addExplicitImport' (IdeDeclValueOperator (IdeValueOperator op (P.Qualified Nothing (Left (P.Ident ""))) 2 P.Infix Nothing)) mn is)

74 addDtorImport i t mn is =

75− prettyPrintImportSection (addExplicitImport' (IdeDataConstructor (P.ProperName i) t wildcard) mn is)

75+ prettyPrintImportSection (addExplicitImport' (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName i) t wildcard)) mn is)

76+ addTypeImport i mn is =

77+ prettyPrintImportSection (addExplicitImport' (IdeDeclType (IdeType (P.ProperName i) P.Star)) mn is)

76 it "adds an implicit unqualified import" $

78 it "adds an implicit unqualified import" $

77 shouldBe

79 shouldBe

78 (addImplicitImport' simpleFileImports (P.moduleNameFromString "Data.Map"))

80 (addImplicitImport' simpleFileImports (P.moduleNameFromString "Data.Map"))

@@ -100,20 +102,26 @@ spec = do

100 shouldBe

102 shouldBe

101 (addOpImport (P.OpName "<~>") (P.moduleNameFromString "Data.Array") explicitImports)

103 (addOpImport (P.OpName "<~>") (P.moduleNameFromString "Data.Array") explicitImports)

102 [ "import Prelude"

104 [ "import Prelude"

103− , "import Data.Array ((<~>), tail)"

105+ , "import Data.Array (tail, (<~>))"

104 ]

106 ]

107+ it "adds a type with constructors without automatically adding an open import of said constructors " $

108+ shouldBe

109+ (addTypeImport "Maybe" (P.moduleNameFromString "Data.Maybe") simpleFileImports)

110+ [ "import Prelude"

111+ , "import Data.Maybe (Maybe)"

112+ ]

105 it "adds the type for a given DataConstructor" $

113 it "adds the type for a given DataConstructor" $

106 shouldBe

114 shouldBe

107 (addDtorImport "Just" (P.ProperName "Maybe") (P.moduleNameFromString "Data.Maybe") simpleFileImports)

115 (addDtorImport "Just" (P.ProperName "Maybe") (P.moduleNameFromString "Data.Maybe") simpleFileImports)

108 [ "import Prelude"

116 [ "import Prelude"

109− , "import Data.Maybe (Maybe(Just))"

117+ , "import Data.Maybe (Maybe(..))"

110 ]

118 ]

111 it "adds a dataconstructor to an existing type import" $ do

119 it "adds a dataconstructor to an existing type import" $ do

112 let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe)"])

120 let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe)"])

113 shouldBe

121 shouldBe

114 (addDtorImport "Just" (P.ProperName "Maybe") (P.moduleNameFromString "Data.Maybe") typeImports)

122 (addDtorImport "Just" (P.ProperName "Maybe") (P.moduleNameFromString "Data.Maybe") typeImports)

115 [ "import Prelude"

123 [ "import Prelude"

116− , "import Data.Maybe (Maybe(Just))"

124+ , "import Data.Maybe (Maybe(..))"

117 ]

125 ]

118 it "doesn't add a dataconstructor to an existing type import with open dtors" $ do

126 it "doesn't add a dataconstructor to an existing type import with open dtors" $ do

119 let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe(..))"])

127 let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe(..))"])

@@ -128,3 +136,38 @@ spec = do

128 [ "import Prelude"

136 [ "import Prelude"

129 , "import Data.Array (tail)"

137 , "import Data.Array (tail)"

130 ]

138 ]

139+

140+ describe "explicit import sorting" $ do

141+ -- given some basic import skeleton

142+ let Right (_, _, baseImports, _) = sliceImportSection $ withImports ["import Control.Monad (ap)"]

143+ moduleName = (P.moduleNameFromString "Control.Monad")

144+ addImport imports import' = addExplicitImport' import' moduleName imports

145+ valueImport ident = (IdeDeclValue (IdeValue (P.Ident ident) wildcard))

146+ typeImport name = (IdeDeclType (IdeType (P.ProperName name) P.Star))

147+ classImport name = (IdeDeclTypeClass (P.ProperName name))

148+ dtorImport name typeName = (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName name) (P.ProperName typeName) wildcard))

149+ -- expect any list of provided identifiers, when imported, to come out as specified

150+ expectSorted imports expected = shouldBe

151+ (ordNub $ map

152+ (prettyPrintImportSection . foldl addImport baseImports)

153+ (permutations imports))

154+ [expected]

155+ it "sorts class" $

156+ expectSorted (map classImport ["Applicative", "Bind"])

157+ ["import Prelude", "import Control.Monad (class Applicative, class Bind, ap)"]

158+ it "sorts value" $

159+ expectSorted (map valueImport ["unless", "where"])

160+ ["import Prelude", "import Control.Monad (ap, unless, where)"]

161+ it "sorts type, value" $

162+ expectSorted

163+ ((map valueImport ["unless", "where"]) ++ (map typeImport ["Foo", "Bar"]))

164+ ["import Prelude", "import Control.Monad (Bar, Foo, ap, unless, where)"]

165+ it "sorts class, type, value" $

166+ expectSorted

167+ ((map valueImport ["unless", "where"]) ++ (map typeImport ["Foo", "Bar"]) ++ (map classImport ["Applicative", "Bind"]))

168+ ["import Prelude", "import Control.Monad (class Applicative, class Bind, Bar, Foo, ap, unless, where)"]

169+ it "sorts types with constructors, using open imports for the constructors" $

170+ expectSorted

171+ -- the imported names don't actually have to exist!

172+ (map (uncurry dtorImport) [("Just", "Maybe"), ("Nothing", "Maybe"), ("SomeOtherConstructor", "SomeDataType")])

173+ ["import Prelude", "import Control.Monad (Maybe(..), SomeDataType(..), ap)"]

tests/Language/PureScript/Ide/MatcherSpec.hs+1−1

@@ -13,7 +13,7 @@ import Language.PureScript.Ide.Util

13import Test.Hspec

14

15value :: Text -> IdeDeclarationAnn

16−value s = withEmptyAnn (IdeValue (P.Ident (toS s)) P.REmpty)

16+value s = withEmptyAnn (IdeDeclValue (IdeValue (P.Ident (toS s)) P.REmpty))

17

18firstResult, secondResult, fiult :: Match IdeDeclarationAnn

19firstResult = Match (P.moduleNameFromString "Match", value "firstResult")

tests/Language/PureScript/Ide/ReexportsSpec.hs+5−5

@@ -18,11 +18,11 @@ d :: IdeDeclaration -> IdeDeclarationAnn

18d = IdeDeclarationAnn emptyAnn

19

20valueA, typeA, classA, dtorA1, dtorA2 :: IdeDeclarationAnn

21−valueA = d (IdeValue (P.Ident "valueA") P.REmpty)

21+valueA = d (IdeDeclValue (IdeValue (P.Ident "valueA") P.REmpty))

22−typeA = d (IdeType (P.ProperName "TypeA") P.Star)

22+typeA = d (IdeDeclType (IdeType(P.ProperName "TypeA") P.Star))

23−classA = d (IdeTypeClass (P.ProperName "ClassA"))

23+classA = d (IdeDeclTypeClass (P.ProperName "ClassA"))

24−dtorA1 = d (IdeDataConstructor (P.ProperName "DtorA1") (P.ProperName "TypeA") P.REmpty)

24+dtorA1 = d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "DtorA1") (P.ProperName "TypeA") P.REmpty))

25−dtorA2 = d (IdeDataConstructor (P.ProperName "DtorA2") (P.ProperName "TypeA") P.REmpty)

25+dtorA2 = d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "DtorA2") (P.ProperName "TypeA") P.REmpty))

26

27env :: Map P.ModuleName [IdeDeclarationAnn]

28env = Map.fromList

tests/Language/PureScript/Ide/StateSpec.hs+6−6

@@ -11,20 +11,20 @@ import qualified Data.Map as Map

11

12valueOperator :: Maybe P.Type -> IdeDeclarationAnn

13valueOperator =

14− d . IdeValueOperator (P.OpName "<$>") (P.Qualified (Just (mn "Test")) (Left (P.Ident "function"))) 2 P.Infix

14+ d . IdeDeclValueOperator . IdeValueOperator (P.OpName "<$>") (P.Qualified (Just (mn "Test")) (Left (P.Ident "function"))) 2 P.Infix

15

16ctorOperator :: Maybe P.Type -> IdeDeclarationAnn

17ctorOperator =

18− d . IdeValueOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (Right (P.ProperName "Cons"))) 2 P.Infix

18+ d . IdeDeclValueOperator . IdeValueOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (Right (P.ProperName "Cons"))) 2 P.Infix

19

20typeOperator :: Maybe P.Kind -> IdeDeclarationAnn

21typeOperator =

22− d . IdeTypeOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (P.ProperName "List")) 2 P.Infix

22+ d . IdeDeclTypeOperator . IdeTypeOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (P.ProperName "List")) 2 P.Infix

23

24testModule :: Module

25−testModule = (mn "Test", [ d (IdeValue (P.Ident "function") P.REmpty)

25+testModule = (mn "Test", [ d (IdeDeclValue (IdeValue (P.Ident "function") P.REmpty))

26− , d (IdeDataConstructor (P.ProperName "Cons") (P.ProperName "List") (P.REmpty))

26+ , d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "Cons") (P.ProperName "List") (P.REmpty)))

27− , d (IdeType (P.ProperName "List") P.Star)

27+ , d (IdeDeclType (IdeType (P.ProperName "List") P.Star))

28 , valueOperator Nothing

29 , ctorOperator Nothing

30 , typeOperator Nothing

tests/TestCompiler.hs+3−2

@@ -31,6 +31,7 @@ import Data.List (sort, stripPrefix, intercalate, groupBy, sortBy, minimumBy)

31import Data.Maybe (mapMaybe)

32import Data.Time.Clock (UTCTime())

33import Data.Tuple (swap)

34+import qualified Data.Text as T

34

35

35import qualified Data.Map as M

36import qualified Data.Map as M

36

37

@@ -71,7 +72,7 @@ spec = do

71 supportPurs <- supportFiles "purs"

72 supportPurs <- supportFiles "purs"

72 supportPursFiles <- readInput supportPurs

73 supportPursFiles <- readInput supportPurs

73 supportExterns <- runExceptT $ do

74 supportExterns <- runExceptT $ do

74− modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles

75+ modules <- ExceptT . return $ P.parseModulesFromFiles id (map (fmap T.pack) supportPursFiles)

75 foreigns <- inferForeignModules modules

76 foreigns <- inferForeignModules modules

76 externs <- ExceptT . fmap fst . runTest $ P.make (makeActions foreigns) (map snd modules)

77 externs <- ExceptT . fmap fst . runTest $ P.make (makeActions foreigns) (map snd modules)

77 return (zip (map snd modules) externs)

78 return (zip (map snd modules) externs)

@@ -194,7 +195,7 @@ compile

194 -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors)

195 -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors)

195compile supportExterns inputFiles check = silence $ runTest $ do

196compile supportExterns inputFiles check = silence $ runTest $ do

196 fs <- liftIO $ readInput inputFiles

197 fs <- liftIO $ readInput inputFiles

197− ms <- P.parseModulesFromFiles id fs

198+ ms <- P.parseModulesFromFiles id (map (fmap T.pack) fs)

198 foreigns <- inferForeignModules ms

199 foreigns <- inferForeignModules ms

199 liftIO (check (map snd ms))

200 liftIO (check (map snd ms))

200 let actions = makeActions foreigns

201 let actions = makeActions foreigns

tests/TestUtils.hs+27−5

@@ -53,16 +53,24 @@ updateSupportCode = do

53--

54supportModules :: [String]

55supportModules =

56+ [ "Control.Alt"

57+ , "Control.Alternative"

56− [ "Control.Applicative"

58+ , "Control.Applicative"

57 , "Control.Apply"

59 , "Control.Apply"

58 , "Control.Bind"

60 , "Control.Bind"

59 , "Control.Category"

61 , "Control.Category"

62+ , "Control.Comonad"

63+ , "Control.Extend"

64+ , "Control.Lazy"

65+ , "Control.Monad"

66+ , "Control.Monad.Eff"

60 , "Control.Monad.Eff.Class"

67 , "Control.Monad.Eff.Class"

61 , "Control.Monad.Eff.Console"

68 , "Control.Monad.Eff.Console"

62 , "Control.Monad.Eff.Unsafe"

69 , "Control.Monad.Eff.Unsafe"

63− , "Control.Monad.Eff"

64 , "Control.Monad.ST"

70 , "Control.Monad.ST"

65− , "Control.Monad"

71+ , "Control.MonadPlus"

72+ , "Control.MonadZero"

73+ , "Control.Plus"

66 , "Control.Semigroupoid"

74 , "Control.Semigroupoid"

67 , "Data.Boolean"

75 , "Data.Boolean"

68 , "Data.BooleanAlgebra"

76 , "Data.BooleanAlgebra"

@@ -71,14 +79,27 @@ supportModules =

71 , "Data.Eq"

79 , "Data.Eq"

72 , "Data.EuclideanRing"

80 , "Data.EuclideanRing"

73 , "Data.Field"

81 , "Data.Field"

74− , "Data.Function.Uncurried"

75 , "Data.Function"

82 , "Data.Function"

83+ , "Data.Function.Uncurried"

76 , "Data.Functor"

84 , "Data.Functor"

85+ , "Data.Functor.Invariant"

86+ , "Data.Generic.Rep"

87+ , "Data.Generic.Rep.Monoid"

88+ , "Data.Generic.Rep.Eq"

89+ , "Data.Generic.Rep.Ord"

90+ , "Data.Generic.Rep.Semigroup"

77 , "Data.HeytingAlgebra"

91 , "Data.HeytingAlgebra"

92+ , "Data.Monoid"

93+ , "Data.Monoid.Additive"

94+ , "Data.Monoid.Conj"

95+ , "Data.Monoid.Disj"

96+ , "Data.Monoid.Dual"

97+ , "Data.Monoid.Endo"

98+ , "Data.Monoid.Multiplicative"

78 , "Data.NaturalTransformation"

99 , "Data.NaturalTransformation"

79 , "Data.Newtype"

100 , "Data.Newtype"

80− , "Data.Ord.Unsafe"

81 , "Data.Ord"

101 , "Data.Ord"

102+ , "Data.Ord.Unsafe"

82 , "Data.Ordering"

103 , "Data.Ordering"

83 , "Data.Ring"

104 , "Data.Ring"

84 , "Data.Semigroup"

105 , "Data.Semigroup"

@@ -90,6 +111,7 @@ supportModules =

90 , "Partial.Unsafe"

111 , "Partial.Unsafe"

91 , "Prelude"

112 , "Prelude"

92 , "Test.Assert"

113 , "Test.Assert"

114+ , "Test.Main"

93 ]

115 ]

94

116

95pushd :: forall a. FilePath -> IO a -> IO a

117pushd :: forall a. FilePath -> IO a -> IO a

tests/support/bower.json+2−1

@@ -8,6 +8,7 @@

8 "purescript-prelude": "1.1.0",

9 "purescript-st": "1.0.0-rc.1",

10 "purescript-partial": "1.1.2",

11− "purescript-newtype": "0.1.0"

11+ "purescript-newtype": "0.1.0",

12+ "purescript-generics-rep": "2.0.0"

12 }

13 }

13}

14}