7e46b25 · rowtype-yoga/purescript-native

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

Merge branch 'master' into pure11

commit7e46b2556e6de742338729cb37f8635bad1adb3e authorAndy Arvanitis <andyarvanitis@gmail.com> dateMon 7 Nov 2016, 10:13 (10 years ago) parent4c26ab0 03bc072

79 files changed+1702−758

compare with golang

unifiedsplit

CONTRIBUTORS.md+3

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

6363- [@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).

6464- [@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).

6565- [@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).

6667- [@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).

6768- [@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).

6869- [@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

8182- [@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).

8283- [@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.

8384- [@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).

8487

8588### Companies

8689

examples/failing/2378.pursnew file+6

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

1+-- @shouldFailWith OrphanInstance

2+module Main where

4+import Lib

6+instance fooX :: Foo "x"

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

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

1+module Lib (class Foo) where

3+class Foo (a :: Symbol)

examples/failing/2379.pursnew file+6

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

1+-- @shouldFailWith UnknownClass

2+module Main where

4+import Lib

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

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

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

1+module Lib (class X, x) where

3+class X a where

4+ x :: a -> String

6+class Y a

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

9+ x _ = "[]"

examples/failing/ConstraintFailure.pursnew file+13

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

1+-- @shouldFailWith NoInstanceFound

3+module Main where

5+import Prelude

7+data Foo = Bar

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

33module Main where

examples/failing/NonWildcardNewtypeInstance.purs+1−1

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

1−-- @shouldFailWith NonWildcardNewtypeInstance

1+-- @shouldFailWith ExpectedWildcard

22module NonWildcardNewtypeInstance where

44import Data.Newtype

examples/passing/2378.pursnew file+9

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

1+module Main where

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

5+class Foo (a :: Symbol)

7+instance fooX :: Foo "x"

9+main = log "Done"

examples/passing/DctorName.pursnew file+33

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

1+module Main where

3+import Prelude

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

6+newtype Bar' = Bar' Int

8+data Foo' = Foo' Bar'

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

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)

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

3+import Prelude

4+import Control.Monad.Eff (Eff)

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

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

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

5+import Prelude

7+import Control.Monad.Eff (Eff)

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

4+import Prelude

6+import Control.Monad.Eff (Eff)

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

3333import System.FilePath.Glob (glob)

3434import System.Exit (exitFailure, exitSuccess)

3535import System.IO (hPutStr, stderr)

36−import System.IO.UTF8 (readUTF8File)

36+import System.IO.UTF8 (readUTF8FileT)

3737

3838import qualified Language.PureScript as P

3939import qualified Paths_purescript as Paths

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

6060

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

6262readInput paths = do

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

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

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

6565

6666compile :: HierarchyOptions -> IO ()

psc-docs/Main.hs+7−6

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

77import Control.Arrow (first, second)

88import Control.Category ((>>>))

99import Control.Monad.Writer

10+import Data.Text (Text)

1011import Data.Function (on)

1112import Data.List

1213import Data.Maybe (fromMaybe)

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

2021import qualified Paths_purescript as Paths

2122import System.Exit (exitFailure)

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

23−import System.IO.UTF8 (readUTF8File)

24+import System.IO.UTF8 (readUTF8FileT)

2425import System.Directory (createDirectoryIfMissing)

2526import System.FilePath (takeDirectory)

2627import System.FilePath.Glob (glob)

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

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

140141 ldump = mapM_ putStrLn

141142

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

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

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

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

144145

145146inputFile :: Parser FilePath

146147inputFile = strArgument $

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

235236 PP.vcat $ map PP.text

236237 [ "Examples:"

237238 , " 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\" \\"

239240 , " --docgen Data.List"

240241 , ""

241242 , " 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\" \\"

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

244245 , ""

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

246247 , " 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\" \\"

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

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

250251 ]

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 #-}

8+module Main where

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)

1515import qualified Data.ByteString.Lazy as B

1616import qualified Data.ByteString.UTF8 as BU8

1717import qualified Data.Map as M

18+import Data.Text (Text)

1819import Data.Version (showVersion)

1920

2021import qualified Language.PureScript as P

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

2930import System.Exit (exitSuccess, exitFailure)

3031import System.FilePath.Glob (glob)

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

32−import System.IO.UTF8

33+import System.IO.UTF8 (readUTF8FileT)

3334

3435data PSCMakeOptions = PSCMakeOptions

3536 { pscmInput :: [FilePath]

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

8586 return paths

8687 concatMapM f = fmap concat . mapM f

8788

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

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

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

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

9091

9192inputFile :: Parser FilePath

9293inputFile = strArgument $

psci/Main.hs+29−22

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

6363

6464-- | Command line options

6565data PSCiOptions = PSCiOptions

66− { psciMultiLineMode :: Bool

67− , psciInputFile :: [FilePath]

66+ { psciInputFile :: [FilePath]

6867 , psciBackend :: Backend

6968 }

7069

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−

7770inputFile :: Opts.Parser FilePath

7871inputFile = Opts.strArgument $

7972 Opts.metavar "FILE"

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

10093 <|> (nodeBackend <$> nodeFlagsFlag)

10194

10295psciOptions :: Opts.Parser PSCiOptions

103−psciOptions = PSCiOptions <$> multiLineMode

104− <*> many inputFile

96+psciOptions = PSCiOptions <$> many inputFile

10597 <*> backend

10698

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

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

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

120112

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

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

124− firstLine <- withInterrupt $ getInputLine "> "

125− case firstLine of

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

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

116+ line <- withInterrupt $ getInputLine "> "

117+ case line of

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

127119 Just "" -> return (Right Nothing)

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

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

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

121+

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

123+pasteMode =

124+ parseCommand <$> go []

130125 where

131126 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 "… "

133128

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

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

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

349344

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

351346 go state = do

352− c <- getCommand (not psciMultiLineMode)

347+ c <- getCommand

353348 case c of

354349 Left err -> outputStrLn err >> go state

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

356356 Right (Just QuitPSCi) -> do

357357 outputStrLn quitMessage

358358 liftIO $ shutdown state

359− Right (Just c') -> do

360− handleInterrupt (outputStrLn "Interrupted.")

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

362− go state

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

366+ handleInterrupt (outputStrLn "Interrupted.")

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

368+ go state

369+

363370 putStrLn prologueMessage

364371 setup >>= runner . go

purescript.cabal+28−3

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

11name: purescript

2−version: 0.10.1

2+version: 0.10.2

33cabal-version: >=1.8

44build-type: Simple

55license: BSD3

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

5555 , examples/passing/TypeWithoutParens/*.purs

5656 , examples/failing/*.purs

5757 , examples/failing/1733/*.purs

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

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

5860 , examples/failing/ConflictingExports/*.purs

5961 , examples/failing/ConflictingImports/*.purs

6062 , examples/failing/ConflictingImports2/*.purs

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

120122 fsnotify >= 0.2.1,

121123 Glob >= 0.7 && < 0.8,

122124 haskeline >= 0.7.0.0,

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

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

124126 http-types -any,

125127 language-javascript == 0.6.*,

128+ lens == 4.*,

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

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

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

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

254257 Language.PureScript.TypeChecker.Subsumption

255258 Language.PureScript.TypeChecker.Synonyms

256259 Language.PureScript.TypeChecker.Types

260+ Language.PureScript.TypeChecker.TypeSearch

257261 Language.PureScript.TypeChecker.Unify

258262 Language.PureScript.TypeClassDictionaries

259263 Language.PureScript.Types

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

347351 mtl -any,

348352 optparse-applicative >= 0.12.1,

349353 parsec -any,

354+ text -any,

350355 time -any,

351356 transformers -any,

352357 transformers-compat -any,

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

400405 optparse-applicative >= 0.12.1,

401406 process -any,

402407 split -any,

408+ text -any,

403409 transformers -any,

404410 transformers-compat -any

405411 main-is: Main.hs

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

423429 hs-source-dirs: psc-publish

424430 ghc-options: -Wall -O2

425431

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+

426450executable psc-hierarchy

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

428452 purescript -any,

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

432456 mtl -any,

433457 optparse-applicative >= 0.12.1,

434458 parsec -any,

435− process -any

459+ process -any,

460+ text -any

436461 main-is: Main.hs

437462 other-modules: Paths_purescript

438463 buildable: True

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

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

88import Prelude.Compat

10+import Control.Applicative

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

1112import Control.Monad.Reader

1213import Control.Monad.State

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

1516import Data.Functor.Identity

1617

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

1920

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

2122runSupplyT n = flip runStateT n . unSupplyT

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

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

11-- |

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

33--

5+{-# LANGUAGE DefaultSignatures #-}

47module Control.Monad.Supply.Class where

69import Prelude.Compat

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

1114

1215class Monad m => MonadSupply m where

1316 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

1422

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

1624 fresh = SupplyT $ do

1725 n <- get

1826 put (n + 1)

1927 return n

28+ peek = SupplyT get

2029

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

22− fresh = lift fresh

23−

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

25− fresh = lift fresh

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

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

2632

2733freshName :: MonadSupply m => m String

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

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

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

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

3030type Context = [(Ident, Type)]

3131

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+

3241-- | A type of error messages

3342data SimpleErrorMessage

3443 = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)

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

7483 | ConstrainedTypeUnified Type Type

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

7685 | NoInstanceFound Constraint

86+ | AmbiguousTypeVariables Type Constraint

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

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

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

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

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

99110 | ShadowedTypeVar String

100111 | UnusedTypeVar String

101112 | WildcardInferredType Type Context

102− | HoleInferredType String Type Context

113+ | HoleInferredType String Type Context TypeSearch

103114 | MissingTypeDeclaration Ident Type

104115 | OverlappingPattern [[Binder]] Bool

105116 | IncompleteExhaustivityCheck

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

123134 | DeprecatedRequirePath

124135 | CannotGeneralizeRecursiveFunction Ident Type

125136 | CannotDeriveNewtypeForData (ProperName 'TypeName)

126− | NonWildcardNewtypeInstance (ProperName 'TypeName)

137+ | ExpectedWildcard (ProperName 'TypeName)

127138 deriving (Show)

128139

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

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

250261 r == (PositionedDeclarationRef _ _ r') = r == r'

251262 _ == _ = False

252263

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+

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

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

255291getTypeRef (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)

474474 in foldMap (f'' s') ds

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

476476 let s' = S.insert name s

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

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

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

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

479480 let s' = S.insert name s

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

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

552553 j' s (DoNotationBind b v) =

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

555556 j' s (DoNotationLet ds) =

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

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

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

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

587588 forValues (TypedValue _ _ ty) = f ty

588589 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_ =

244244 ret <- valueToJs val

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

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

247− return $ JSVariableIntroduction Nothing ctor (Just $

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

248248 JSObjectLiteral Nothing [("create",

249249 JSFunction Nothing Nothing ["value"]

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

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

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

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

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

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

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

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

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

256256 let constructor =

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

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

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

262− in return $ iife ctor [ constructor

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

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

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

264264 ]

265265

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

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

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

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

2727--

2828identToJs :: 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

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

3135 | otherwise = concatMap identCharToString name

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

3336

3437-- |

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

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

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

101101

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−

111102inlineCommonOperators :: JS -> JS

112103inlineCommonOperators = applyAll $

113104 [ binary semiringNumber opAdd Add

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

159150 , binary heytingAlgebraBoolean opDisj Or

160151 , unary heytingAlgebraBoolean opNot Not

161152

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

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

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

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

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

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

165156 , binary' C.dataIntBits C.shl ShiftLeft

166157 , binary' C.dataIntBits C.shr ShiftRight

167158 , binary' C.dataIntBits C.zshr ZeroFillShiftRight

168159 , unary' C.dataIntBits C.complement BitwiseNot

169160

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

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

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

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

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

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

173164 ] ++

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

175166 where

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

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

234225 go _ _ _ = Nothing

235226

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+

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

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

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

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

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

118118unsafeIndex :: String

119119unsafeIndex = "unsafeIndex"

120120

121−(.|.) :: String

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

121+or :: String

122+or = "or"

123123

124−(.&.) :: String

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

124+and :: String

125+and = "and"

126126

127−(.^.) :: String

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

127+xor :: String

128+xor = "xor"

129129

130130(<<<) :: String

131131(<<<) = "<<<"

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

346346prelude :: String

347347prelude = "Prelude"

348348

349−dataArrayUnsafe :: String

350−dataArrayUnsafe = "Data_Array_Unsafe"

349+dataArray :: String

350+dataArray = "Data_Array"

351351

352352eff :: String

353353eff = "Control_Monad_Eff"

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

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

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

1010

1111import qualified Data.Map as M

12+import Data.Text (Text)

1213

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

1415import Language.PureScript.Docs.Types

1516import qualified Language.PureScript as P

16−

17−import System.IO.UTF8 (readUTF8File)

18−

17+import System.IO.UTF8 (readUTF8FileT)

1918import Web.Bower.PackageMeta (PackageName)

2019

2120-- |

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

4544

4645parseFiles ::

4746 (MonadError P.MultipleErrors m) =>

48− [(FileInfo, FilePath)]

47+ [(FileInfo, Text)]

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

5049parseFiles =

5150 throwLeft . P.parseModulesFromFiles fileInfoToString

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

7776fileInfoToString (Local fn) = fn

7877fileInfoToString (FromDep _ fn) = fn

7978

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

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

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

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

8281

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

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

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

8584

8685getDepsModuleNames :: [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)

236236

237237-- |

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

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

240−-- the class with the same name.

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

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

241241--

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

243243primTypes =

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

257257 ]

258258

259259-- |

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

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

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

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

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

262263--

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

264265primClasses =

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

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

4040import qualified Text.Parsec as P

4141import qualified Text.Parsec.Error as PE

4242import qualified Text.PrettyPrint.Boxes as Box

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

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

4445

4546newtype ErrorSuggestion = ErrorSuggestion String

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

117118 ConstrainedTypeUnified{} -> "ConstrainedTypeUnified"

118119 OverlappingInstances{} -> "OverlappingInstances"

119120 NoInstanceFound{} -> "NoInstanceFound"

121+ AmbiguousTypeVariables{} -> "AmbiguousTypeVariables"

122+ UnknownClass{} -> "UnknownClass"

120123 PossiblyInfiniteInstance{} -> "PossiblyInfiniteInstance"

121124 CannotDerive{} -> "CannotDerive"

122125 InvalidNewtypeInstance{} -> "InvalidNewtypeInstance"

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

166169 DeprecatedRequirePath{} -> "DeprecatedRequirePath"

167170 CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction"

168171 CannotDeriveNewtypeForData{} -> "CannotDeriveNewtypeForData"

169− NonWildcardNewtypeInstance{} -> "NonWildcardNewtypeInstance"

172+ ExpectedWildcard{} -> "ExpectedWildcard"

170173

171174-- |

172175-- A stack trace for an error

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

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

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

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

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

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

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

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

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

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

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

268272 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

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

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

272276 gSimple other = pure other

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

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

281285 gHint other = pure other

282286

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

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

289+

283290wikiUri :: ErrorMessage -> String

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

285292

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

287294-- WildcardInferredType - source span not small enough

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

289296errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion

290−errorSuggestion err = case err of

291− UnusedImport{} -> emptySuggestion

292− DuplicateImport{} -> emptySuggestion

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

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

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

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

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

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

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

300− WildcardInferredType ty _ -> suggest $ prettyPrintType ty

301− _ -> Nothing

302−

297+errorSuggestion err =

298+ case err of

299+ UnusedImport{} -> emptySuggestion

300+ DuplicateImport{} -> emptySuggestion

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

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

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

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

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

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

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

308+ WildcardInferredType ty _ -> suggest $ prettyPrintSuggestedType ty

309+ _ -> Nothing

303310 where

304311 emptySuggestion = Just $ ErrorSuggestion ""

305312 suggest = Just . ErrorSuggestion

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

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

596603 ]

597604 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+ ]

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

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

600612 , indent box

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

626638 where

627639 go TUnknown{} = True

628640 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+ ]

629646 renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =

630647 paras [ line "Type class instance for"

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

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

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

734751 , markCodeBox $ indent $ typeAsBox ty

735752 ] ++ renderContext ctx

736− renderSimpleErrorMessage (HoleInferredType name ty ctx) =

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

738− , markCodeBox $ indent $ typeAsBox ty

739− ] ++ renderContext 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

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

776+ , markCodeBox (indent (typeAsBox ty))

777+ ] ++ tsResult ++ renderContext ctx

740778 renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =

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

742780 , 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

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

835873 ]

836874

837− renderSimpleErrorMessage (NonWildcardNewtypeInstance tyName) =

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

875+ renderSimpleErrorMessage (ExpectedWildcard tyName) =

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

839877 ]

840878

841879 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

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

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

1212-- Casesplitting and adding function clauses

1313-----------------------------------------------------------------------------

1414

15−{-# LANGUAGE OverloadedStrings #-}

15+{-# LANGUAGE OverloadedStrings #-}

1616

1717module Language.PureScript.Ide.CaseSplit

1818 ( WildcardAnnotations()

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

2323 , caseSplit

2424 ) where

2525

26−import Protolude hiding (Constructor)

26+import Protolude hiding (Constructor)

2727

28−import qualified Data.Text as T

29−import qualified Language.PureScript as P

28+import qualified Data.Text as T

29+import qualified Language.PureScript as P

3030

3131import Language.PureScript.Externs

3232import Language.PureScript.Ide.Error

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

3434import Language.PureScript.Ide.Types

3535import Language.PureScript.Ide.Util

3636

37−import Text.Parsec as Parsec

38−import qualified Text.PrettyPrint.Boxes as Box

37+import Text.Parsec as Parsec

38+import qualified Text.PrettyPrint.Boxes as Box

3939

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

4141

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

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

1212-- Datatypes for the commands psc-ide accepts

1313-----------------------------------------------------------------------------

1414

15−{-# LANGUAGE OverloadedStrings #-}

15+{-# LANGUAGE OverloadedStrings #-}

16+

1617

1718module Language.PureScript.Ide.Command where

1819

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

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

1414

1515module Language.PureScript.Ide.Conversions where

1616

17−import Protolude

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

17+import Control.Lens.Iso

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

1919import qualified Language.PureScript as P

20+import Protolude

2021

2122runProperNameT :: P.ProperName a -> Text

2223runProperNameT = toS . P.runProperName

2324

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

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

27+

2428runIdentT :: P.Ident -> Text

2529runIdentT = toS . P.runIdent

2630

31+identT :: Iso' P.Ident Text

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

33+

2734runOpNameT :: P.OpName a -> Text

2835runOpNameT = toS . P.runOpName

2936

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

3239

3340prettyTypeT :: P.Type -> Text

3441prettyTypeT = 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

1717 ( PscIdeError(..)

1818 ) where

1919

20−import Protolude

2120import Data.Aeson

2221import Language.PureScript.Errors.JSON

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

24−import qualified Text.Parsec.Error as P

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

23+import Protolude

24+import qualified Text.Parsec.Error as P

2525

2626data PscIdeError

2727 = GeneralError Text

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

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

1414

1515{-# LANGUAGE OverloadedStrings #-}

1616{-# LANGUAGE RecordWildCards #-}

17−{-# LANGUAGE FlexibleContexts #-}

1817

1918module Language.PureScript.Ide.Externs

2019 ( readExternFile

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

2423

2524import Protolude

2625

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

2727import Data.Aeson (decodeStrict)

28+import qualified Data.ByteString as BS

2829import Data.List (nub)

2930import qualified Data.Map as Map

30−import qualified Data.ByteString as BS

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

3232import Language.PureScript.Ide.Types

3333import Language.PureScript.Ide.Util

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

5858 cleanDeclarations = nub $ appEndo typeClassFilter declarations

5959

6060removeTypeDeclarationsForClass :: IdeDeclaration -> Endo [IdeDeclaration]

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

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

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

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

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

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

6464 notDuplicate _ = True

6565removeTypeDeclarationsForClass _ = mempty

6666

6767isTypeClassDeclaration :: IdeDeclaration -> Bool

68−isTypeClassDeclaration IdeTypeClass{} = True

68+isTypeClassDeclaration IdeDeclTypeClass{} = True

6969isTypeClassDeclaration _ = False

7070

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

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

7373convertExport _ = Nothing

7474

7575convertDecl :: P.ExternsDeclaration -> Maybe IdeDeclaration

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

77−convertDecl P.EDTypeSynonym{..} =

78− Just (IdeTypeSynonym edTypeSynonymName edTypeSynonymType)

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

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

77+ IdeType edTypeName edTypeKind

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

79+ (IdeSynonym edTypeSynonymName edTypeSynonymType)

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

8081 IdeDataConstructor edDataCtorName edDataCtorTypeCtor edDataCtorType

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

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

8283 IdeValue edValueName edValueType

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

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

8485convertDecl P.EDInstance{} = Nothing

8586

8687convertOperator :: P.ExternsFixity -> IdeDeclaration

8788convertOperator P.ExternsFixity{..} =

88− IdeValueOperator

89+ IdeDeclValueOperator $ IdeValueOperator

8990 efOperator

9091 efAlias

9192 efPrecedence

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

9495

9596convertTypeOperator :: P.ExternsTypeFixity -> IdeDeclaration

9697convertTypeOperator P.ExternsTypeFixity{..} =

97− IdeTypeOperator

98+ IdeDeclTypeOperator $ IdeTypeOperator

9899 efTypeOperator

99100 efTypeAlias

100101 efTypePrecedence

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

110111 where

111112 convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn

112113 convertDeclaration (IdeDeclarationAnn ann d) = case d of

113− IdeValue i t ->

114− annotateFunction i (IdeValue i t)

115− IdeType i k ->

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

117− IdeTypeSynonym i t ->

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

119− IdeDataConstructor i tn t ->

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

121− IdeTypeClass i ->

122− annotateType (runProperNameT i) (IdeTypeClass i)

123− IdeValueOperator n i p a t ->

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

125− IdeTypeOperator n i p a k ->

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

114+ IdeDeclValue v ->

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

116+ IdeDeclType t ->

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

118+ IdeDeclTypeSynonym s ->

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

120+ IdeDeclDataConstructor dtor ->

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

122+ IdeDeclTypeClass i ->

123+ annotateType (runProperNameT i) (IdeDeclTypeClass i)

124+ IdeDeclValueOperator op ->

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

126+ IdeDeclTypeOperator op ->

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

127128 where

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

129130 , annTypeAnnotation = Map.lookup x types

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

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

2323 , applyFilters

2424 ) where

2525

26−import Protolude hiding (isPrefixOf)

26+import Protolude hiding (isPrefixOf)

2727

2828import Data.Aeson

2929import Data.Text (isPrefixOf)

30+import qualified Language.PureScript as P

3031import Language.PureScript.Ide.Types

3132import Language.PureScript.Ide.Util

32−import qualified Language.PureScript as P

3333

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

3535

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

6565 where

6666 filterModuleDecls :: Module -> Module

6767 filterModuleDecls (moduleIdent, decls) =

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

69− getDeclaration (IdeDeclarationAnn _ d) = d

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

7069

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

7271runFilter (Filter f) = appEndo f

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

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

3030 where

3131

3232import Protolude

33+

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

35+import Data.List (findIndex, nubBy)

3336import qualified Data.Text as T

34−import Data.List (nubBy, findIndex)

35−import qualified Data.Text.IO as TIO

3637import qualified Language.PureScript as P

3738import Language.PureScript.Ide.Completion

3839import Language.PureScript.Ide.Error

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

4041import Language.PureScript.Ide.State

4142import Language.PureScript.Ide.Types

4243import Language.PureScript.Ide.Util

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

4345

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

4547 deriving (Eq, Show)

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

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

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

7274parseImportsFromFile fp = do

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

75+ file <- liftIO (readUTF8FileT fp)

7476 case sliceImportSection (T.lines file) of

7577 Right res -> pure res

7678 Left err -> throwError (GeneralError err)

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

197199 then imports

198200 else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports

199201 where

200− refFromDeclaration (IdeTypeClass n) =

202+ refFromDeclaration (IdeDeclTypeClass n) =

201203 P.TypeClassRef n

202− refFromDeclaration (IdeDataConstructor n tn _) =

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

204− refFromDeclaration (IdeType n _) =

205− P.TypeRef n (Just [])

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

207− P.ValueOpRef op

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

209− P.TypeOpRef op

204+ refFromDeclaration (IdeDeclDataConstructor dtor) =

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

206+ refFromDeclaration (IdeDeclType t) =

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

208+ refFromDeclaration (IdeDeclValueOperator op) =

209+ P.ValueOpRef (op ^. ideValueOpName)

210+ refFromDeclaration (IdeDeclTypeOperator op) =

211+ P.TypeOpRef (op ^. ideTypeOpName)

210212 refFromDeclaration d =

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

212214

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

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

215217 insertDeclIntoImport :: IdeDeclaration -> Import -> Import

216218 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

218220 insertDeclIntoImport _ is = is

219221

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

221− insertDeclIntoRefs (IdeDataConstructor dtor tn _) refs =

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

223+ insertDeclIntoRefs d@(IdeDeclDataConstructor dtor) refs =

224+ updateAtFirstOrPrepend

225+ (matchType (dtor ^. ideDtorTypeName))

226+ (insertDtor (dtor ^. ideDtorName))

227+ (refFromDeclaration d)

228+ refs

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

224230

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

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 _ (P.TypeRef tn' _) = P.TypeRef tn' Nothing

231232 insertDtor _ refs = refs

232233

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

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

294295 xs ->

295296 pure $ Left xs

296297 where

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

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

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

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

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

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

300301 Just ts

301302 decideRedundantCase _ _ = Nothing

302303

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

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

317318answerRequest outfp rs =

318319 case outfp of

319− Nothing -> pure $ MultilineTextResult rs

320+ Nothing -> pure (MultilineTextResult rs)

320321 Just outfp' -> do

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

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

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

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

323324

324325-- | Test and ghci helper

325326parseImport :: Text -> Maybe Import

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

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

1212-- Matchers for psc-ide commands

1313-----------------------------------------------------------------------------

1414

15+{-# LANGUAGE FlexibleInstances #-}

1516{-# LANGUAGE GeneralizedNewtypeDeriving #-}

1617{-# LANGUAGE OverloadedStrings #-}

17−{-# LANGUAGE FlexibleInstances #-}

1818

1919module Language.PureScript.Ide.Matcher

2020 ( Matcher

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

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

1212-- Pursuit client for psc-ide

1313-----------------------------------------------------------------------------

1414

15−{-# LANGUAGE OverloadedStrings #-}

15+{-# LANGUAGE OverloadedStrings #-}

1616

1717module Language.PureScript.Ide.Pursuit

1818 ( searchPursuitForDeclarations

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

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

3636queryPursuit :: Text -> IO ByteString

3737queryPursuit q = do

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

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

40− let req = req'

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

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

43− }

44− m <- newManager tlsManagerSettings

45− withHTTP req m $ \resp ->

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

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

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

40+ let req = req'

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

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

43+ }

44+ m <- newManager tlsManagerSettings

45+ withHTTP req m $ \resp ->

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

47+

4748

4849handler :: HttpException -> IO [a]

50+handler StatusCodeException{} = pure []

4951handler _ = pure []

5052

5153searchPursuitForDeclarations :: Text -> IO [PursuitResponse]

52−searchPursuitForDeclarations query = E.handle handler $ do

53− r <- queryPursuit query

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

55− case results' of

56− Nothing -> pure []

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

54+searchPursuitForDeclarations query =

55+ (do r <- queryPursuit query

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

57+ case results' of

58+ Nothing -> pure []

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

60+ handler

5861 where

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

6063 isDeclarationResponse _ = Nothing

6164

6265findPackagesForModuleIdent :: Text -> IO [PursuitResponse]

63−findPackagesForModuleIdent query = E.handle handler $ do

64− r <- queryPursuit query

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

66− case results' of

66+findPackagesForModuleIdent query =

67+ (do r <- queryPursuit query

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

69+ case results' of

6770 Nothing -> pure []

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

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

72+ handler

6973 where

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

7175 isModuleResponse _ = Nothing

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

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

1111import Protolude

1212

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

14−import qualified Data.List as List

14+import qualified Data.List as List

1515import qualified Data.Map.Lazy as M

1616import Data.Maybe (fromJust)

1717import qualified Data.Set as S

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

2121import Language.PureScript.Ide.State

2222import Language.PureScript.Ide.Types

2323import Language.PureScript.Ide.Util

24−import System.IO.UTF8 (readUTF8File)

24+import System.IO.UTF8 (readUTF8FileT)

2525

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

2727--

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

4444 -> m Success

4545rebuildFile path = do

4646

47− input <- liftIO (readUTF8File path)

47+ input <- liftIO (readUTF8FileT path)

4848

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

5050 Left parseError -> throwError

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

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

2525

2626import Protolude

2727

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

29+

2830import qualified Data.Map as Map

31+import qualified Language.PureScript as P

2932import Language.PureScript.Ide.Types

3033import Language.PureScript.Ide.Util

31−import qualified Language.PureScript as P

3234

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

3436data ReexportResult a

3537 = ReexportResult

3638 { reResolved :: a

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

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

3840 } deriving (Show, Eq, Functor)

3941

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

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

7981 -> Either P.DeclarationRef [IdeDeclarationAnn]

8082resolveRef decls ref = case ref of

8183 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

8385 Nothing -> Left ref

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

8587 Nothing ->

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

8991 findDtors tn

9092 Just dtors -> mapMaybe lookupDtor dtors

9193 P.ValueRef i ->

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

93− P.TypeOpRef name ->

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

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

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

9799 P.TypeClassRef name ->

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

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

99101 _ ->

100102 Left ref

101103 where

102− findWrapped = wrapSingle . findRef

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

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

104105 findRef f = find (f . discardAnn) decls

105106

106107 lookupDtor name =

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

108− _ -> False)

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

109109

110110 findDtors tn = filter (f . discardAnn) decls

111111 where

112112 f :: IdeDeclaration -> Bool

113− f decl

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

115− , tn == tn' = True

116− | otherwise = False

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

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

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

1212-- Getting declarations from PureScript sourcefiles

1313-----------------------------------------------------------------------------

1414

15−{-# LANGUAGE OverloadedStrings #-}

15+{-# LANGUAGE OverloadedStrings #-}

1616

1717module Language.PureScript.Ide.SourceFile

1818 ( parseModule

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

2525

2626import Protolude

2727

28−import qualified Data.Map as Map

29−import qualified Language.PureScript as P

28+import qualified Data.Map as Map

29+import qualified Language.PureScript as P

3030import Language.PureScript.Ide.Error

31−import Language.PureScript.Ide.Util

3231import Language.PureScript.Ide.Types

33−import System.IO.UTF8 (readUTF8File)

32+import Language.PureScript.Ide.Util

33+import System.IO.UTF8 (readUTF8FileT)

3434

3535parseModule

3636 :: (MonadIO m)

3737 => FilePath

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

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

3939parseModule path = do

40− contents <- liftIO (readUTF8File path)

40+ contents <- liftIO (readUTF8FileT path)

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

4242 Left _ -> pure (Left path)

4343 Right m -> pure (Right m)

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

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

3232 , resolveOperatorsForModule

3333 ) where

3434

35−import Protolude

3635import qualified Prelude

36+import Protolude

3737

3838import Control.Concurrent.STM

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

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

40−import qualified Data.Map.Lazy as Map

41−import qualified Data.List as List

41+import qualified Data.Map.Lazy as Map

42+import qualified Language.PureScript as P

4243import Language.PureScript.Externs

4344import Language.PureScript.Ide.Externs

4445import Language.PureScript.Ide.Reexports

4546import Language.PureScript.Ide.SourceFile

4647import Language.PureScript.Ide.Types

4748import Language.PureScript.Ide.Util

48−import qualified Language.PureScript as P

4949import System.Clock

5050

5151-- | Resets all State inside psc-ide

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

235235 :: Map P.ModuleName [IdeDeclarationAnn]

236236 -> [IdeDeclarationAnn]

237237 -> [IdeDeclarationAnn]

238−resolveOperatorsForModule modules = map (mapIdeDeclaration resolveOperator)

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

239239 where

240− resolveOperator (IdeValueOperator

241− opName

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

243− (Left ident)) precedence assoc _) =

244− let t = do

245− sourceModule <- Map.lookup moduleName modules

246− IdeValue _ tP <-

247− List.find (\case

248− IdeValue iP _ -> iP == ident

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)

256− (Right ctor)) precedence assoc _) =

257− let t = do

258− sourceModule <- Map.lookup moduleName modules

259− IdeDataConstructor _ _ tP <-

260− List.find (\case

261− IdeDataConstructor cname _ _ -> ctor == cname

262− _ -> False) (discardAnn <$> sourceModule)

263− pure tP

264−

265− in IdeValueOperator opName i precedence assoc t

266− resolveOperator (IdeTypeOperator

267− opName

268− i@(P.Qualified (Just moduleName) properName) precedence assoc _) =

269− let k = do

270− sourceModule <- Map.lookup moduleName modules

271− IdeType _ kP <-

272− List.find (\case

273− IdeType name _ -> name == properName

274− _ -> False) (discardAnn <$> sourceModule)

275− pure kP

276−

277− in IdeTypeOperator opName i precedence assoc k

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+

249+ resolveOperator (IdeDeclValueOperator op)

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

251+ let t = getDeclarations mn

252+ & mapMaybe (preview _IdeDeclValue)

253+ & filter (hasName ideValueIdent ident)

254+ & map (view ideValueType)

255+ & listToMaybe

256+ in IdeDeclValueOperator (op & ideValueOpType .~ t)

257+ | (P.Qualified (Just mn) (Right dtor)) <- op ^. ideValueOpAlias =

258+ let t = getDeclarations mn

259+ & mapMaybe (preview _IdeDeclDataConstructor)

260+ & filter (hasName ideDtorName dtor)

261+ & map (view ideDtorType)

262+ & listToMaybe

263+ in IdeDeclValueOperator (op & ideValueOpType .~ t)

264+ resolveOperator (IdeDeclTypeOperator op)

265+ | P.Qualified (Just mn) properName <- op ^. ideTypeOpAlias =

266+ let k = getDeclarations mn

267+ & mapMaybe (preview _IdeDeclType)

268+ & filter (hasName ideTypeName properName)

269+ & map (view ideTypeKind)

270+ & listToMaybe

271+ in IdeDeclTypeOperator (op & ideTypeOpKind .~ k)

278272 resolveOperator x = x

279273

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

1212-- Type definitions for psc-ide

1313-----------------------------------------------------------------------------

1414

15−{-# LANGUAGE OverloadedStrings #-}

1615{-# LANGUAGE DeriveFoldable #-}

16+{-# LANGUAGE OverloadedStrings #-}

17+{-# LANGUAGE TemplateHaskell #-}

1718

1819module Language.PureScript.Ide.Types where

1920

2021import Protolude

2122

2223import Control.Concurrent.STM

24+import Control.Lens.TH

2325import Data.Aeson

24−import qualified Data.Map.Lazy as M

25−import qualified Language.PureScript.Errors.JSON as P

26−import qualified Language.PureScript as P

26+import qualified Data.Map.Lazy as M

27+import qualified Language.PureScript as P

28+import qualified Language.PureScript.Errors.JSON as P

2729import Language.PureScript.Ide.Conversions

2830

2931type ModuleIdent = Text

3032

3133data IdeDeclaration

32− = IdeValue P.Ident P.Type

33− | IdeType (P.ProperName 'P.TypeName) P.Kind

34− | IdeTypeSynonym (P.ProperName 'P.TypeName) P.Type

35− | IdeDataConstructor (P.ProperName 'P.ConstructorName) (P.ProperName 'P.TypeName) P.Type

36− | IdeTypeClass (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)

38− | IdeTypeOperator (P.OpName 'P.TypeOpName) (P.Qualified (P.ProperName 'P.TypeName)) P.Precedence P.Associativity (Maybe P.Kind)

34+ = IdeDeclValue IdeValue

35+ | IdeDeclType IdeType

36+ | IdeDeclTypeSynonym IdeSynonym

37+ | IdeDeclDataConstructor IdeDataConstructor

38+ | IdeDeclTypeClass (P.ProperName 'P.ClassName)

39+ | IdeDeclValueOperator IdeValueOperator

40+ | IdeDeclTypeOperator IdeTypeOperator

3941 deriving (Show, Eq, Ord)

4042

41−data IdeDeclarationAnn = IdeDeclarationAnn Annotation IdeDeclaration

42− deriving (Show, Eq, Ord)

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+

88+data IdeDeclarationAnn = IdeDeclarationAnn

89+ { _idaAnnotation :: Annotation

90+ , _idaDeclaration :: IdeDeclaration

91+ } deriving (Show, Eq, Ord)

4392

4493data Annotation

4594 = Annotation

46− { annLocation :: Maybe P.SourceSpan

47− , annExportedFrom :: Maybe P.ModuleName

95+ { annLocation :: Maybe P.SourceSpan

96+ , annExportedFrom :: Maybe P.ModuleName

4897 , annTypeAnnotation :: Maybe P.Type

4998 } deriving (Show, Eq, Ord)

5099

100+makeLenses ''IdeDeclarationAnn

101+

51102emptyAnn :: Annotation

52103emptyAnn = Annotation Nothing Nothing Nothing

53104

@@ -103,7 +154,7 @@ data Stage2 = Stage2

103154 }

104155

105156data Stage3 = Stage3

106− { s3Declarations :: M.Map P.ModuleName [IdeDeclarationAnn]

157+ { s3Declarations :: M.Map P.ModuleName [IdeDeclarationAnn]

107158 , s3CachedRebuild :: Maybe (P.ModuleName, P.ExternsFile)

108159 }

109160

@@ -112,11 +163,11 @@ newtype Match a = Match (P.ModuleName, a)

112163

113164-- | A completion as it gets sent to the editors

114165data Completion = Completion

115− { complModule :: Text

116− , complIdentifier :: Text

117− , complType :: Text

118− , complExpandedType :: Text

119− , complLocation :: Maybe P.SourceSpan

166+ { complModule :: Text

167+ , complIdentifier :: Text

168+ , complType :: Text

169+ , complExpandedType :: Text

170+ , complLocation :: Maybe P.SourceSpan

120171 , complDocumentation :: Maybe Text

121172 } deriving (Show, Eq)

122173

src/Language/PureScript/Ide/Util.hs+26−24

@@ -29,23 +29,25 @@ module Language.PureScript.Ide.Util

2929 , module Language.PureScript.Ide.Conversions

3030 ) where

3131

32−import Protolude hiding (decodeUtf8, encodeUtf8)

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

3333import Data.Aeson

34−import qualified Data.Text as T

35−import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)

36−import qualified Language.PureScript as P

37−import Language.PureScript.Ide.Types

34+import qualified Data.Text as T

35+import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)

36+import qualified Language.PureScript as P

3837import Language.PureScript.Ide.Conversions

38+import Language.PureScript.Ide.Types

39+import Protolude hiding (decodeUtf8,

40+ encodeUtf8)

3941

4042identifierFromIdeDeclaration :: IdeDeclaration -> Text

4143identifierFromIdeDeclaration d = case d of

42− IdeValue name _ -> runIdentT name

43− IdeType name _ -> runProperNameT name

44− IdeTypeSynonym name _ -> runProperNameT name

45− IdeDataConstructor name _ _ -> runProperNameT name

46− IdeTypeClass name -> runProperNameT name

47− IdeValueOperator op _ _ _ _ -> runOpNameT op

48− IdeTypeOperator op _ _ _ _ -> runOpNameT op

44+ IdeDeclValue v -> v ^. ideValueIdent . identT

45+ IdeDeclType t -> t ^. ideTypeName . properNameT

46+ IdeDeclTypeSynonym s -> s ^. ideSynonymName . properNameT

47+ IdeDeclDataConstructor dtor -> dtor ^. ideDtorName . properNameT

48+ IdeDeclTypeClass name -> runProperNameT name

49+ IdeDeclValueOperator op -> op ^. ideValueOpName & runOpNameT

50+ IdeDeclTypeOperator op -> op ^. ideTypeOpName & runOpNameT

4951

5052discardAnn :: IdeDeclarationAnn -> IdeDeclaration

5153discardAnn (IdeDeclarationAnn _ d) = d

@@ -61,24 +63,24 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) =

6163 Completion {..}

6264 where

6365 (complIdentifier, complExpandedType) = case decl of

64− IdeValue name type' -> (runIdentT name, prettyTypeT type')

65− IdeType name kind -> (runProperNameT name, toS (P.prettyPrintKind kind))

66− IdeTypeSynonym name kind -> (runProperNameT name, prettyTypeT kind)

67− IdeDataConstructor name _ type' -> (runProperNameT name, prettyTypeT type')

68− IdeTypeClass name -> (runProperNameT name, "class")

69− IdeValueOperator op ref precedence associativity typeP ->

70− (runOpNameT op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP)

71− IdeTypeOperator op ref precedence associativity kind ->

66+ IdeDeclValue v -> (v ^. ideValueIdent . identT, v ^. ideValueType & prettyTypeT)

67+ IdeDeclType t -> (t ^. ideTypeName . properNameT, t ^. ideTypeKind & P.prettyPrintKind & toS )

68+ IdeDeclTypeSynonym s -> (s ^. ideSynonymName . properNameT, s ^. ideSynonymType & prettyTypeT)

69+ IdeDeclDataConstructor d -> (d ^. ideDtorName . properNameT, d ^. ideDtorType & prettyTypeT)

70+ IdeDeclTypeClass name -> (runProperNameT name, "class")

71+ IdeDeclValueOperator (IdeValueOperator op ref precedence associativity typeP) ->

72+ (runOpNameT op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP)

73+ IdeDeclTypeOperator (IdeTypeOperator op ref precedence associativity kind) ->

7274 (runOpNameT op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) (toS . P.prettyPrintKind) kind)

73−

75+

7476 complModule = runModuleNameT m

7577

7678 complType = maybe complExpandedType prettyTypeT (annTypeAnnotation ann)

77−

79+

7880 complLocation = annLocation ann

7981

8082 complDocumentation = Nothing

81−

83+

8284 showFixity p a r o =

8385 let asso = case a of

8486 P.Infix -> "infix"

@@ -95,7 +97,7 @@ typeOperatorAliasT

9597 :: P.Qualified (P.ProperName 'P.TypeName) -> Text

9698typeOperatorAliasT i =

9799 toS (P.showQualified P.runProperName i)

98−

100+

99101encodeT :: (ToJSON a) => a -> Text

100102encodeT = toS . decodeUtf8 . encode

101103

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

@@ -104,7 +104,7 @@ handleCommand _ _ (KindOf typ) = handleKindOf typ

104104handleCommand _ _ (BrowseModule moduleName) = handleBrowse moduleName

105105handleCommand _ _ (ShowInfo QueryLoaded) = handleShowLoadedModules

106106handleCommand _ _ (ShowInfo QueryImport) = handleShowImportedModules

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

107+handleCommand _ _ _ = P.internalError "handleCommand: unexpected command"

108108

109109-- | Reset the application state

110110handleResetState

src/Language/PureScript/Interactive/Completion.hs+1

@@ -122,6 +122,7 @@ directiveArg _ Browse = [CtxModule]

122122directiveArg _ Quit = []

123123directiveArg _ Reset = []

124124directiveArg _ Help = []

125+directiveArg _ Paste = []

125126directiveArg _ Show = map CtxFixed replQueryStrings

126127directiveArg _ Type = [CtxIdentifier]

127128directiveArg _ Kind = [CtxType]

src/Language/PureScript/Interactive/Directive.hs+3

@@ -30,6 +30,7 @@ directiveStrings =

3030 , (Type , ["type"])

3131 , (Kind , ["kind"])

3232 , (Show , ["show"])

33+ , (Paste , ["paste"])

3334 ]

3435

3536-- |

@@ -82,6 +83,7 @@ hasArgument :: Directive -> Bool

8283hasArgument Help = False

8384hasArgument Quit = False

8485hasArgument Reset = False

86+hasArgument Paste = False

8587hasArgument _ = True

8688

8789-- |

@@ -97,4 +99,5 @@ help =

9799 , (Kind, "<type>", "Show the kind of <type>")

98100 , (Show, "import", "Show all imported modules")

99101 , (Show, "loaded", "Show all loaded modules")

102+ , (Paste, "paste", "Enter multiple lines, terminated by ^D")

100103 ]

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

33import Prelude.Compat

55import Control.Monad (msum)

66import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

77import System.Directory (createDirectoryIfMissing, getHomeDirectory, findExecutable)

8−import System.FilePath (takeDirectory, (</>), isPathSeparator)

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

1010mkdirp :: FilePath -> IO ()

1111mkdirp = createDirectoryIfMissing True . takeDirectory

@@ -32,10 +32,3 @@ getHistoryFilename = do

3232 let filename = home </> ".purescript" </> "psci_history"

3333 mkdirp filename

3434 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

3939

4040supportModuleMessage :: String

4141supportModuleMessage = unlines

42− [ "PSCi requires the purescript-psci-support package to be installed."

42+ [ "PSCi requires the psci-support package to be installed."

4343 , "You can install it using Bower as follows:"

4444 , ""

4545 , " bower i purescript-psci-support --save-dev"

4646 , ""

47+ , "Or using psc-package:"

48+ , ""

49+ , " psc-package install psci-support"

50+ , ""

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

4852 ]

4953

src/Language/PureScript/Interactive/Module.hs+3−3

@@ -6,7 +6,7 @@ import Control.Monad

66import qualified Language.PureScript as P

77import Language.PureScript.Interactive.Types

88import System.FilePath (pathSeparator)

9−import System.IO.UTF8 (readUTF8File)

9+import System.IO.UTF8 (readUTF8FileT)

1010

1111-- * Support Module

1212

@@ -25,7 +25,7 @@ supportModuleIsDefined = any ((== supportModuleName) . P.getModuleName)

2525--

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

2727loadModule filename = do

28− content <- readUTF8File filename

28+ content <- readUTF8FileT filename

2929 return $ either (Left . P.prettyPrintMultipleErrors P.defaultPPEOptions) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]

3030

3131-- |

@@ -34,7 +34,7 @@ loadModule filename = do

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

3535loadAllModules files = do

3636 filesAndContent <- forM files $ \filename -> do

37− content <- readUTF8File filename

37+ content <- readUTF8FileT filename

3838 return (filename, content)

3939 return $ P.parseModulesFromFiles id filesAndContent

4040

src/Language/PureScript/Interactive/Parser.hs+1

@@ -62,6 +62,7 @@ parseDirective cmd =

6262 Help -> return ShowHelp

6363 Quit -> return QuitPSCi

6464 Reset -> return ResetState

65+ Paste -> return PasteLines

6566 Browse -> BrowseModule <$> parseRest P.moduleName arg

6667 Show -> ShowInfo <$> parseReplQuery' (trim arg)

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

7272-- Valid Meta-commands for PSCI

7373--

7474data Command

75− -- |

76− -- A purescript expression

77− --

75+ -- | A purescript expression

7876 = Expression P.Expr

79− -- |

80− -- Show the help (ie, list of directives)

81− --

77+ -- | Show the help (ie, list of directives)

8278 | ShowHelp

83− -- |

84− -- Import a module from a loaded file

85− --

79+ -- | Import a module from a loaded file

8680 | Import ImportedModule

87− -- |

88− -- Browse a module

89− --

81+ -- | Browse a module

9082 | BrowseModule P.ModuleName

91− -- |

92− -- Exit PSCI

93− --

83+ -- | Exit PSCI

9484 | QuitPSCi

95− -- |

96− -- Reset the state of the REPL

97− --

85+ -- | Reset the state of the REPL

9886 | ResetState

99− -- |

100− -- Add some declarations to the current evaluation context.

101− --

87+ -- | Add some declarations to the current evaluation context

10288 | Decls [P.Declaration]

103− -- |

104− -- Find the type of an expression

105− --

89+ -- | Find the type of an expression

10690 | TypeOf P.Expr

107− -- |

108− -- Find the kind of an expression

109− --

91+ -- | Find the kind of an expression

11092 | KindOf P.Type

111− -- |

112− -- Shows information about the current state of the REPL

113− --

93+ -- | Shows information about the current state of the REPL

11494 | ShowInfo ReplQuery

95+ -- | Paste multiple lines

96+ | PasteLines

11597

11698data ReplQuery

11799 = QueryLoaded

@@ -142,4 +124,5 @@ data Directive

142124 | Type

143125 | Kind

144126 | Show

127+ | Paste

145128 deriving (Eq, Show)

src/Language/PureScript/Linter/Imports.hs+1−1

@@ -308,7 +308,7 @@ findUsedRefs env mni qn names =

308308 typesRefs

309309 = map (flip TypeRef (Just [])) typesWithoutDctors

310310 ++ 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

312312

313313 where

314314

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

@@ -149,7 +149,7 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do

149149 lint withPrim

150150 ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do

151151 [desugared] <- desugar externs [withPrim]

152− runCheck' env $ typeCheckModule desugared

152+ runCheck' (emptyCheckState env) $ typeCheckModule desugared

153153 regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated

154154 let mod' = Module ss coms moduleName regrouped exps

155155 corefn = CF.moduleToCoreFn env' mod'

src/Language/PureScript/Parser/Common.hs+14−5

@@ -28,6 +28,12 @@ properName = ProperName <$> uname

2828typeName :: TokenParser (ProperName 'TypeName)

2929typeName = ProperName <$> tyname

3030

31+-- |

32+-- Parse a proper name for a data constructor.

33+--

34+dataConstructorName :: TokenParser (ProperName 'ConstructorName)

35+dataConstructorName = ProperName <$> dconsname

36+

3137-- |

3238-- Parse a module name

3339--

@@ -107,23 +113,26 @@ mark p = do

107113-- |

108114-- Check that the current identation level matches a predicate

109115--

110−checkIndentation :: (P.Column -> P.Column -> Bool) -> P.Parsec s ParseState ()

111−checkIndentation rel = do

116+checkIndentation

117+ :: (P.Column -> String)

118+ -> (P.Column -> P.Column -> Bool)

119+ -> P.Parsec s ParseState ()

120+checkIndentation mkMsg rel = do

112121 col <- P.sourceColumn <$> P.getPosition

113122 current <- indentationLevel <$> P.getState

114− guard (col `rel` current)

123+ guard (col `rel` current) P.<?> mkMsg current

115124

116125-- |

117126-- Check that the current indentation level is past the current mark

118127--

119128indented :: P.Parsec s ParseState ()

120−indented = checkIndentation (>) P.<?> "indentation"

129+indented = checkIndentation (("indentation past column " ++) . show) (>)

121130

122131-- |

123132-- Check that the current indentation level is at the same indentation as the current mark

124133--

125134same :: P.Parsec s ParseState ()

126−same = checkIndentation (==) P.<?> "no indentation"

135+same = checkIndentation (("indentation at column " ++) . show) (==)

127136

128137-- |

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

1919

2020import Data.Functor (($>))

2121import Data.Maybe (fromMaybe)

22+import Data.Text (Text)

2223

2324import Control.Applicative

2425import Control.Arrow ((+++))

@@ -71,7 +72,7 @@ parseDataDeclaration = do

7172 tyArgs <- many (indented *> kindedIdent)

7273 ctors <- P.option [] $ do

7374 indented *> equals

74− P.sepBy1 ((,) <$> properName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe

75+ P.sepBy1 ((,) <$> dataConstructorName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe

7576 return $ DataDeclaration dtype name tyArgs ctors

7677

7778parseTypeDeclaration :: TokenParser Declaration

@@ -281,7 +282,7 @@ parseModulesFromFiles

281282 :: forall m k

282283 . MonadError MultipleErrors m

283284 => (k -> FilePath)

284− -> [(k, String)]

285+ -> [(k, Text)]

285286 -> m [(k, Module)]

286287parseModulesFromFiles toFilePath input =

287288 flip parU wrapError . inParallel . flip map input $ parseModuleFromFile toFilePath

@@ -298,11 +299,11 @@ parseModulesFromFiles toFilePath input =

298299-- | Parses a single module with FilePath for eventual parsing errors

299300parseModuleFromFile

300301 :: (k -> FilePath)

301− -> (k, String)

302+ -> (k, Text)

302303 -> Either P.ParseError (k, Module)

303304parseModuleFromFile toFilePath (k, content) = do

304305 let filename = toFilePath k

305− ts <- lex filename content

306+ ts <- lex' filename content

306307 m <- runTokenParser filename parseModule ts

307308 pure (k, m)

308309

@@ -360,7 +361,7 @@ parseVar :: TokenParser Expr

360361parseVar = Var <$> C.parseQualified C.parseIdent

361362

362363parseConstructor :: TokenParser Expr

363−parseConstructor = Constructor <$> C.parseQualified C.properName

364+parseConstructor = Constructor <$> C.parseQualified C.dataConstructorName

364365

365366parseCase :: TokenParser Expr

366367parseCase = Case <$> P.between (reserved "case") (C.indented *> reserved "of") (commaSep1 parseValue)

@@ -494,10 +495,10 @@ parseNumberLiteral = LiteralBinder . NumericLiteral <$> (sign <*> number)

494495 <|> return id

495496

496497parseNullaryConstructorBinder :: TokenParser Binder

497−parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> pure []

498+parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.dataConstructorName <*> pure []

498499

499500parseConstructorBinder :: TokenParser Binder

500−parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> many (C.indented *> parseBinderNoParens)

501+parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.dataConstructorName <*> many (C.indented *> parseBinderNoParens)

501502

502503parseObjectBinder:: TokenParser Binder

503504parseObjectBinder = LiteralBinder <$> parseObjectLiteral (C.indented *> parseIdentifierAndBinder)

src/Language/PureScript/Parser/Lexer.hs+34−19

@@ -6,6 +6,7 @@ module Language.PureScript.Parser.Lexer

66 , Token()

77 , TokenParser()

88 , lex

9+ , lex'

910 , anyToken

1011 , token

1112 , match

@@ -43,6 +44,7 @@ module Language.PureScript.Parser.Lexer

4344 , lname'

4445 , qualifier

4546 , tyname

47+ , dconsname

4648 , uname

4749 , uname'

4850 , mname

@@ -68,6 +70,8 @@ import Control.Monad (void, guard)

6870

6971import Data.Char (isSpace, isAscii, isSymbol, isAlphaNum)

7072import Data.Functor.Identity

73+import Data.Text (Text)

74+import qualified Data.Text as T

7175

7276import Language.PureScript.Comments

7377import Language.PureScript.Parser.State

@@ -153,8 +157,13 @@ data PositionedToken = PositionedToken

153157instance Show PositionedToken where

154158 show = prettyPrintToken . ptToken

155159

160+type Lexer u a = P.Parsec Text u a

161+

156162lex :: FilePath -> String -> Either P.ParseError [PositionedToken]

157−lex f s = updatePositions <$> P.parse parseTokens f s

163+lex fp = lex' fp . T.pack

164+

165+lex' :: FilePath -> Text -> Either P.ParseError [PositionedToken]

166+lex' f s = updatePositions <$> P.parse parseTokens f s

158167

159168updatePositions :: [PositionedToken] -> [PositionedToken]

160169updatePositions [] = []

@@ -162,22 +171,22 @@ updatePositions (x:xs) = x : zipWith update (x:xs) xs

162171 where

163172 update PositionedToken { ptEndPos = pos } pt = pt { ptPrevEndPos = Just pos }

164173

165−parseTokens :: P.Parsec String u [PositionedToken]

174+parseTokens :: Lexer u [PositionedToken]

166175parseTokens = whitespace *> P.many parsePositionedToken <* P.skipMany parseComment <* P.eof

167176

168−whitespace :: P.Parsec String u ()

177+whitespace :: Lexer u ()

169178whitespace = P.skipMany (P.satisfy isSpace)

170179

171−parseComment :: P.Parsec String u Comment

180+parseComment :: Lexer u Comment

172181parseComment = (BlockComment <$> blockComment <|> LineComment <$> lineComment) <* whitespace

173182 where

174− blockComment :: P.Parsec String u String

183+ blockComment :: Lexer u String

175184 blockComment = P.try $ P.string "{-" *> P.manyTill P.anyChar (P.try (P.string "-}"))

176185

177− lineComment :: P.Parsec String u String

186+ lineComment :: Lexer u String

178187 lineComment = P.try $ P.string "--" *> P.manyTill P.anyChar (P.try (void (P.char '\n') <|> P.eof))

179188

180−parsePositionedToken :: P.Parsec String u PositionedToken

189+parsePositionedToken :: Lexer u PositionedToken

181190parsePositionedToken = P.try $ do

182191 comments <- P.many parseComment

183192 pos <- P.getPosition

@@ -186,7 +195,7 @@ parsePositionedToken = P.try $ do

186195 whitespace

187196 return $ PositionedToken pos pos' Nothing tok comments

188197

189−parseToken :: P.Parsec String u Token

198+parseToken :: Lexer u Token

190199parseToken = P.choice

191200 [ P.try $ P.string "<-" *> P.notFollowedBy symbolChar *> pure LArrow

192201 , P.try $ P.string "←" *> P.notFollowedBy symbolChar *> pure LArrow

@@ -225,34 +234,34 @@ parseToken = P.choice

225234 ]

226235

227236 where

228− parseLName :: P.Parsec String u String

237+ parseLName :: Lexer u String

229238 parseLName = (:) <$> identStart <*> P.many identLetter

230239

231− parseUName :: P.Parsec String u String

240+ parseUName :: Lexer u String

232241 parseUName = (:) <$> P.upper <*> P.many identLetter

233242

234− parseSymbol :: P.Parsec String u String

243+ parseSymbol :: Lexer u String

235244 parseSymbol = P.many1 symbolChar

236245

237− identStart :: P.Parsec String u Char

246+ identStart :: Lexer u Char

238247 identStart = P.lower <|> P.oneOf "_"

239248

240− identLetter :: P.Parsec String u Char

249+ identLetter :: Lexer u Char

241250 identLetter = P.alphaNum <|> P.oneOf "_'"

242251

243− symbolChar :: P.Parsec String u Char

252+ symbolChar :: Lexer u Char

244253 symbolChar = P.satisfy isSymbolChar

245254

246− parseCharLiteral :: P.Parsec String u Char

255+ parseCharLiteral :: Lexer u Char

247256 parseCharLiteral = PT.charLiteral tokenParser

248257

249− parseStringLiteral :: P.Parsec String u String

258+ parseStringLiteral :: Lexer u String

250259 parseStringLiteral = blockString <|> PT.stringLiteral tokenParser

251260 where

252261 delimiter = P.try (P.string "\"\"\"")

253262 blockString = delimiter >> P.manyTill P.anyChar delimiter

254263

255− parseNumber :: P.Parsec String u (Either Integer Double)

264+ parseNumber :: Lexer u (Either Integer Double)

256265 parseNumber = (consumeLeadingZero >> P.parserZero) <|>

257266 (Right <$> P.try (PT.float tokenParser) <|>

258267 Left <$> P.try (PT.natural tokenParser))

@@ -266,7 +275,7 @@ parseToken = P.choice

266275-- |

267276-- We use Text.Parsec.Token to implement the string and number lexemes

268277--

269−langDef :: PT.GenLanguageDef String u Identity

278+langDef :: PT.GenLanguageDef Text u Identity

270279langDef = PT.LanguageDef

271280 { PT.reservedNames = []

272281 , PT.reservedOpNames = []

@@ -284,7 +293,7 @@ langDef = PT.LanguageDef

284293-- |

285294-- A token parser based on the language definition

286295--

287−tokenParser :: PT.GenTokenParser String u Identity

296+tokenParser :: PT.GenTokenParser Text u Identity

288297tokenParser = PT.makeTokenParser langDef

289298

290299type TokenParser a = P.Parsec [PositionedToken] ParseState a

@@ -452,6 +461,12 @@ tyname = token go P.<?> "type name"

452461 go (UName s) = Just s

453462 go _ = Nothing

454463

464+dconsname :: TokenParser String

465+dconsname = token go P.<?> "data constructor name"

466+ where

467+ go (UName s) = Just s

468+ go _ = Nothing

469+

455470mname :: TokenParser String

456471mname = token go P.<?> "module name"

457472 where

src/Language/PureScript/Pretty/Types.hs+42−27

@@ -3,7 +3,9 @@

33--

44module Language.PureScript.Pretty.Types

55 ( typeAsBox

6+ , suggestedTypeAsBox

67 , prettyPrintType

8+ , prettyPrintSuggestedType

79 , typeAtomAsBox

810 , prettyPrintTypeAtom

911 , prettyPrintRowWith

@@ -27,23 +29,6 @@ import Language.PureScript.Types

2729

2830import Text.PrettyPrint.Boxes hiding ((<+>))

2931

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−

4732constraintsAsBox :: [Constraint] -> Box -> Box

4833constraintsAsBox [con] ty = text "(" <> constraintAsBox con `before` (text ") => " <> ty)

4934constraintsAsBox 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

120105 match (ParensInType ty) = Just ((), ty)

121106 match _ = Nothing

122107

123−matchTypeAtom :: Pattern () Type Box

124−matchTypeAtom = typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) matchType

125−

126−matchType :: Pattern () Type Box

127−matchType = buildPrettyPrinter operators matchTypeAtom

108+matchTypeAtom :: Bool -> Pattern () Type Box

109+matchTypeAtom suggesting =

110+ typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) (matchType suggesting)

128111 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

129134 operators :: OperatorTable () Type Box

130135 operators =

131136 OperatorTable [ [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ]

@@ -152,7 +157,7 @@ forall_ = mkPattern match

152157typeAtomAsBox :: Type -> Box

153158typeAtomAsBox

154159 = fromMaybe (internalError "Incomplete pattern")

155− . PA.pattern matchTypeAtom ()

160+ . PA.pattern (matchTypeAtom False) ()

156161 . insertPlaceholders

157162

158163-- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses

@@ -160,11 +165,21 @@ prettyPrintTypeAtom :: Type -> String

160165prettyPrintTypeAtom = render . typeAtomAsBox

161166

162167typeAsBox :: 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

164175 = fromMaybe (internalError "Incomplete pattern")

165− . PA.pattern matchType ()

176+ . PA.pattern (matchType suggesting) ()

166177 . insertPlaceholders

167178

168−-- | Generate a pretty-printed string representing a Type

179+-- | Generate a pretty-printed string representing a 'Type'

169180prettyPrintType :: 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)

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

1414import Control.Monad.Supply.Class (MonadSupply)

1515

16−import Data.List (foldl', find, sortBy)

16+import Data.List (foldl', find, sortBy, unzip5)

1717import Data.Maybe (fromMaybe)

1818import Data.Ord (comparing)

1919

@@ -58,9 +58,14 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwr

5858 | className == Qualified (Just dataNewtype) (ProperName "Newtype")

5959 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy

6060 , mn == fromMaybe mn mn'

61− = do

62− (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon args unwrappedTy

63− return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst)

61+ = do (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon args unwrappedTy

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)

6469deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)

6570 = throwError . errorMessage $ CannotDerive className tys

6671deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@(_ : _) NewtypeInstance)

@@ -122,6 +127,9 @@ deriveNewtypeInstance className ds tys tyConNm dargs = do

122127dataGeneric :: ModuleName

123128dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]

124129

130+dataGenericRep :: ModuleName

131+dataGenericRep = ModuleName [ ProperName "Data", ProperName "Generic", ProperName "Rep" ]

132+

125133dataMaybe :: ModuleName

126134dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]

127135

@@ -304,6 +312,187 @@ deriveGeneric mn ds tyConNm dargs = do

304312 mkGenVar :: Ident -> Expr

305313 mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic]))

306314

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+

307496deriveEq ::

308497 forall m. (MonadError MultipleErrors m, MonadSupply m)

309498 => ModuleName

@@ -451,7 +640,7 @@ deriveNewtype

451640 -> Type

452641 -> m ([Declaration], Type)

453642deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do

454− checkIsWildcard unwrappedTy

643+ checkIsWildcard tyConNm unwrappedTy

455644 go =<< findTypeDecl tyConNm ds

456645 where

457646 go :: Declaration -> m ([Declaration], Type)

@@ -477,12 +666,6 @@ deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do

477666 go (PositionedDeclaration _ _ d) = go d

478667 go _ = internalError "deriveNewtype go: expected DataDeclaration"

479668

480− checkIsWildcard :: Type -> m ()

481− checkIsWildcard (TypeWildcard _) =

482− return ()

483− checkIsWildcard _ =

484− throwError . errorMessage $ NonWildcardNewtypeInstance tyConNm

485−

486669findTypeDecl

487670 :: (MonadError MultipleErrors m)

488671 => ProperName 'TypeName

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

@@ -11,7 +11,7 @@ module Language.PureScript.TypeChecker

1111

1212import Prelude.Compat

1313

14−import Control.Monad (when, unless, void, forM, forM_)

14+import Control.Monad (when, unless, void, forM)

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

1616import Control.Monad.State.Class (MonadState(..), modify)

1717import Control.Monad.Supply.Class (MonadSupply)

@@ -279,7 +279,6 @@ typeCheckAll moduleName _ = traverse go

279279 return d

280280 go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do

281281 traverse_ (checkTypeClassInstance moduleName) tys

282− forM_ deps $ traverse_ (checkTypeClassInstance moduleName) . constraintArgs

283282 checkOrphanInstance dictName className tys

284283 _ <- traverseTypeInstanceBody checkInstanceMembers body

285284 let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps)

@@ -313,6 +312,7 @@ typeCheckAll moduleName _ = traverse go

313312 where

314313 checkType :: Type -> Bool

315314 checkType (TypeVar _) = False

315+ checkType (TypeLevelString _) = False

316316 checkType (TypeConstructor (Qualified (Just mn'') _)) = moduleName == mn''

317317 checkType (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance"

318318 checkType (TypeApp t1 _) = checkType t1

src/Language/PureScript/TypeChecker/Entailment.hs+38−25

@@ -5,8 +5,10 @@

55--

66module Language.PureScript.TypeChecker.Entailment

77 ( InstanceContext

8+ , SolverOptions(..)

89 , replaceTypeClassDictionaries

910 , newDictionaries

11+ , entails

1012 ) where

1113

1214import Prelude.Compat

@@ -56,7 +58,7 @@ replaceTypeClassDictionaries

5658 . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)

5759 => Bool

5860 -> Expr

59− -> m (Expr, [(Ident, Constraint)])

61+ -> m (Expr, [(Ident, InstanceContext, Constraint)])

6062replaceTypeClassDictionaries shouldGeneralize expr = flip evalStateT M.empty $ do

6163 -- Loop, deferring any unsolved constraints, until there are no more

6264 -- constraints which can be solved, then make a generalization pass.

@@ -70,18 +72,18 @@ replaceTypeClassDictionaries shouldGeneralize expr = flip evalStateT M.empty $ d

7072 -- This pass solves constraints where possible, deferring constraints if not.

7173 deferPass :: Expr -> StateT InstanceContext m (Expr, Any)

7274 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

7476 (_, f, _) = everywhereOnValuesTopDownM return (go True) return

7577

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

7880 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

8082 (_, f, _) = everywhereOnValuesTopDownM return (go False) return

8183

82− go :: Bool -> Expr -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr

83− go deferErrors dict@(TypeClassDictionary _ _ hints) =

84− rethrow (addHints hints) $ entails shouldGeneralize deferErrors dict

84+ go :: Bool -> Expr -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr

85+ go deferErrors (TypeClassDictionary constraint context hints) =

86+ rethrow (addHints hints) $ entails (SolverOptions shouldGeneralize deferErrors) constraint context hints

8587 go _ other = return other

8688

8789-- | Three options for how we can handle a constraint, depending on the mode we're in.

@@ -93,18 +95,29 @@ data EntailsResult a

9395 | Deferred

9496 -- ^ We couldn't solve this constraint right now, so it has been deferred

9597

96−-- |

97−-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,

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+

106+-- | Check that the current set of type class dictionaries entail the specified type class goal, and, if so,

98107-- return a type class dictionary reference.

99−--

100108entails

101109 :: forall m

102110 . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)

103− => Bool

104− -> Bool

105− -> Expr

106− -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr

107−entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hints) =

111+ => SolverOptions

112+ -- ^ Solver options

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

119+ -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr

120+entails SolverOptions{..} constraint context hints =

108121 solve constraint

109122 where

110123 forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]

@@ -123,10 +136,10 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin

123136 valUndefined :: Expr

124137 valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))

125138

126− solve :: Constraint -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr

139+ solve :: Constraint -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr

127140 solve con = go 0 con

128141 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

130143 go work (Constraint className' tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'

131144 go work con'@(Constraint className' tys' conInfo) = WriterT . StateT . (withErrorMessageHint (ErrorSolvingConstraint con') .) . runStateT . runWriterT $ do

132145 -- We might have unified types by solving other constraints, so we need to

@@ -137,8 +150,10 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin

137150 inferred <- lift get

138151 -- We need information about functional dependencies, so we have to look up the class

139152 -- name in the environment:

140− let findClass = fromMaybe (internalError "entails: type class not found in environment") . M.lookup className'

141− TypeClassData{ typeClassDependencies } <- lift . lift $ gets (findClass . typeClasses . checkEnv)

153+ classesInScope <- lift . lift $ gets (typeClasses . checkEnv)

154+ TypeClassData{ typeClassDependencies } <- case M.lookup className' classesInScope of

155+ Nothing -> throwError . errorMessage $ UnknownClass className'

156+ Just tcd -> pure tcd

142157 let instances =

143158 [ (substs, tcd)

144159 | tcd <- forClassName (combineContexts context inferred) className' tys''

@@ -179,7 +194,7 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin

179194 let newContext = mkContext newDicts

180195 modify (combineContexts newContext)

181196 -- Mark this constraint for generalization

182− tell (mempty, [(ident, unsolved)])

197+ tell (mempty, [(ident, context, unsolved)])

183198 return (Var qident)

184199 Deferred ->

185200 -- Constraint was deferred, just return the dictionary unchanged,

@@ -219,10 +234,10 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin

219234

220235 unique :: [Type] -> [(a, TypeClassDictionaryInScope)] -> m (EntailsResult a)

221236 unique tyArgs []

222− | deferErrors = return Deferred

237+ | solverDeferErrors = return Deferred

223238 -- We need a special case for nullary type classes, since we want

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

226241 | otherwise = throwError . errorMessage $ NoInstanceFound (Constraint className' tyArgs conInfo)

227242 unique _ [(a, dict)] = return $ Solved a dict

228243 unique tyArgs tcds

@@ -233,7 +248,6 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin

233248

234249 canBeGeneralized :: Type -> Bool

235250 canBeGeneralized TUnknown{} = True

236− canBeGeneralized Skolem{} = True

237251 canBeGeneralized _ = False

238252

239253 -- |

@@ -251,7 +265,7 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin

251265 -- Create dictionaries for subgoals which still need to be solved by calling go recursively

252266 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type

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

255269 solveSubgoals _ Nothing = return Nothing

256270 solveSubgoals subst (Just subgoals) =

257271 Just <$> traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars (M.toList subst)))) subgoals

@@ -268,7 +282,6 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin

268282 App (Accessor (C.__superclass_ ++ showQualified runProperName superclassName ++ "_" ++ show index)

269283 dict)

270284 valUndefined

271−entails _ _ _ = internalError "entails: expected TypeClassDictionary"

272285

273286-- Check if an instance matches our list of types, allowing for types

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

257257

258258-- | Run a computation in the typechecking monad, starting with an empty @Environment@

259259runCheck :: (Functor m) => StateT CheckState m a -> m (a, Environment)

260−runCheck = runCheck' initEnvironment

260+runCheck = runCheck' (emptyCheckState initEnvironment)

261261

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

264−runCheck' env check = second checkEnv <$> runStateT check (emptyCheckState env)

263+runCheck' :: (Functor m) => CheckState -> StateT CheckState m a -> m (a, Environment)

264+runCheck' st check = second checkEnv <$> runStateT check st

265265

266266-- | Make an assertion, failing with an error message

267267guardWith :: (MonadError e m) => e -> Bool -> m ()

src/Language/PureScript/TypeChecker/Subsumption.hs+109−59

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

1−-- |

2−-- Subsumption checking

3−--

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE GADTs #-}

3+{-# LANGUAGE TypeFamilies #-}

5+-- | Subsumption checking

46module Language.PureScript.TypeChecker.Subsumption

57 ( subsumes

68 ) where

@@ -25,72 +27,120 @@ import Language.PureScript.TypeChecker.Skolems

2527import Language.PureScript.TypeChecker.Unify

2628import Language.PureScript.Types

2729

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+

2862-- | Check that one type subsumes another, rethrowing errors to provide a better error message

29−subsumes :: (MonadError MultipleErrors m, MonadState CheckState m) => Maybe Expr -> Type -> Type -> m (Maybe Expr)

30−subsumes val ty1 ty2 = withErrorMessageHint (ErrorInSubsumption ty1 ty2) $ subsumes' val ty1 ty2

63+subsumes

64+ :: (MonadError MultipleErrors m, MonadState CheckState m)

65+ => Type

66+ -> Type

67+ -> m (Expr -> Expr)

68+subsumes ty1 ty2 =

69+ withErrorMessageHint (ErrorInSubsumption ty1 ty2) $

70+ subsumes' SElaborate ty1 ty2

3171

3272-- | Check that one type subsumes another

33−subsumes' :: (MonadError MultipleErrors m, MonadState CheckState m) =>

34− Maybe Expr ->

35− Type ->

36− Type ->

37− m (Maybe Expr)

38−subsumes' val (ForAll ident ty1 _) ty2 = do

73+subsumes'

74+ :: (MonadError MultipleErrors m, MonadState CheckState m)

75+ => ModeSing mode

76+ -> Type

77+ -> Type

78+ -> m (Coercion mode)

79+subsumes' mode (ForAll ident ty1 _) ty2 = do

3980 replaced <- replaceVarWithUnknown ident ty1

40− subsumes val replaced ty2

41−subsumes' val ty1 (ForAll ident ty2 sco) =

81+ subsumes' mode replaced ty2

82+subsumes' mode ty1 (ForAll ident ty2 sco) =

4283 case sco of

4384 Just sco' -> do

4485 sko <- newSkolemConstant

4586 let sk = skolemize ident sko sco' Nothing ty2

46− subsumes val ty1 sk

87+ subsumes' mode ty1 sk

4788 Nothing -> internalError "subsumes: unspecified skolem scope"

48−subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do

49− _ <- subsumes Nothing arg2 arg1

50− _ <- subsumes Nothing ret1 ret2

51− return val

52−subsumes' val (KindedType ty1 _) ty2 =

53− subsumes val ty1 ty2

54−subsumes' val ty1 (KindedType ty2 _) =

55− subsumes val ty1 ty2

56−subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do

89+subsumes' mode (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do

90+ subsumes' SNoElaborate arg2 arg1

91+ subsumes' SNoElaborate ret1 ret2

92+ -- Nothing was elaborated, return the default coercion

93+ return (defaultCoercion mode)

94+subsumes' mode (KindedType ty1 _) ty2 =

95+ subsumes' mode ty1 ty2

96+subsumes' mode ty1 (KindedType ty2 _) =

97+ subsumes' mode ty1 ty2

98+-- Only check subsumption for constrained types when elaborating.

99+-- Otherwise fall back to unification.

100+subsumes' SElaborate (ConstrainedType constraints ty1) ty2 = do

57101 dicts <- getTypeClassDictionaries

58102 hints <- gets checkHints

59− subsumes' (Just $ foldl App val (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) ty1 ty2

60−subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyRecord && f2 == tyRecord = do

61− let

62− (ts1, r1') = rowToList r1

63− (ts2, r2') = rowToList r2

64− ts1' = sortBy (comparing fst) ts1

65− ts2' = sortBy (comparing fst) ts2

66− -- 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.

68− -- 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.

70− when (r1' == REmpty)

71− (for_ (firstMissingProp ts2' ts1') (throwError . errorMessage . PropertyIsMissing . fst))

72− when (r2' == REmpty)

73− (for_ (firstMissingProp ts1' ts2') (throwError . errorMessage . AdditionalProperty . fst))

74− go ts1' ts2' r1' r2'

75− return val

103+ elaborate <- subsumes' SElaborate ty1 ty2

104+ let addDicts val = foldl App val (map (\cs -> TypeClassDictionary cs dicts hints) constraints)

105+ return (elaborate . addDicts)

106+subsumes' mode (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyRecord && f2 == tyRecord = do

107+ let

108+ (ts1, r1') = rowToList r1

109+ (ts2, r2') = rowToList r2

110+ ts1' = sortBy (comparing fst) ts1

111+ ts2' = sortBy (comparing fst) ts2

112+ -- For { ts1 | r1 } to subsume { ts2 | r2 } when r1 is empty (= we're working with a closed row),

113+ -- every property in ts2 must appear in ts1. If not, then the candidate expression is missing a required property.

114+ -- Conversely, when r2 is empty, every property in ts1 must appear in ts2, or else the expression has

115+ -- an additional property which is not allowed.

116+ when (r1' == REmpty)

117+ (for_ (firstMissingProp ts2' ts1') (throwError . errorMessage . PropertyIsMissing . fst))

118+ when (r2' == REmpty)

119+ (for_ (firstMissingProp ts1' ts2') (throwError . errorMessage . AdditionalProperty . fst))

120+ go ts1' ts2' r1' r2'

121+ -- Nothing was elaborated, return the default coercion

122+ return (defaultCoercion mode)

76123 where

77− go [] ts2 r1' r2' = unifyTypes r1' (rowFromList (ts2, r2'))

78− go ts1 [] r1' r2' = unifyTypes r2' (rowFromList (ts1, r1'))

79− go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1' r2'

80− | p1 == p2 = do _ <- subsumes Nothing ty1 ty2

81− go ts1 ts2 r1' r2'

82− | p1 < p2 = do rest <- freshType

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

85− -- in which case, this branch of the subsumes function should not even be necessary.

86− unifyTypes r2' (RCons p1 ty1 rest)

87− go ts1 ((p2, ty2) : ts2) r1' rest

88− | otherwise = do rest <- freshType

89− unifyTypes r1' (RCons p2 ty2 rest)

90− go ((p1, ty1) : ts1) ts2 rest r2'

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

93−subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyRecord = subsumes val ty2 ty1

94−subsumes' val ty1 ty2 = do

124+ go [] ts2 r1' r2' = unifyTypes r1' (rowFromList (ts2, r2'))

125+ go ts1 [] r1' r2' = unifyTypes r2' (rowFromList (ts1, r1'))

126+ go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1' r2'

127+ | p1 == p2 = do subsumes' SNoElaborate ty1 ty2

128+ go ts1 ts2 r1' r2'

129+ | p1 < p2 = do rest <- freshType

130+ -- What happens next is a bit of a hack.

131+ -- TODO: in the new type checker, object properties will probably be restricted to being monotypes

132+ -- in which case, this branch of the subsumes function should not even be necessary.

133+ unifyTypes r2' (RCons p1 ty1 rest)

134+ go ts1 ((p2, ty2) : ts2) r1' rest

135+ | otherwise = do rest <- freshType

136+ unifyTypes r1' (RCons p2 ty2 rest)

137+ go ((p1, ty1) : ts1) ts2 rest r2'

138+

139+ -- Find the first property that's in the first list (of tuples) but not in the second

140+ firstMissingProp t1 t2 = fst <$> uncons (minusBy' (comparing fst) t1 t2)

141+subsumes' mode ty1 ty2@(TypeApp obj _) | obj == tyRecord =

142+ subsumes' mode ty2 ty1

143+subsumes' mode ty1 ty2 = do

95144 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 #-}

5+module Language.PureScript.TypeChecker.TypeSearch

6+ ( typeSearch

7+ ) where

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 #-}

12{-# LANGUAGE OverloadedStrings #-}

23{-# LANGUAGE NamedFieldPuns #-}

@@ -27,13 +28,16 @@ module Language.PureScript.TypeChecker.Types

2728

2829import Prelude.Compat

2930

31+import Control.Arrow (first, second, (***))

3032import Control.Monad

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

3234import Control.Monad.State.Class (MonadState(..), gets)

3335import Control.Monad.Supply.Class (MonadSupply)

3436import Control.Monad.Writer.Class (MonadWriter(..))

3537

38+import Data.Bifunctor (bimap)

3639import Data.Either (lefts, rights)

40+import Data.Functor (($>))

3741import Data.List (transpose, nub, (\\), partition, delete)

3842import Data.Maybe (fromMaybe)

3943import qualified Data.Map as M

@@ -53,9 +57,11 @@ import Language.PureScript.TypeChecker.Rows

5357import Language.PureScript.TypeChecker.Skolems

5458import Language.PureScript.TypeChecker.Subsumption

5559import Language.PureScript.TypeChecker.Synonyms

60+import Language.PureScript.TypeChecker.TypeSearch

5661import Language.PureScript.TypeChecker.Unify

5762import Language.PureScript.Types

5863

64+

5965data BindingGroupType

6066 = RecursiveBindingGroup

6167 | NonRecursiveBindingGroup

@@ -70,13 +76,13 @@ typesOf

7076 -> [(Ident, Expr)]

7177 -> m [(Ident, (Expr, Type))]

7278typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do

73− (tys, w) <- withoutWarnings . capturingSubstitution tidyUp $ do

79+ tys <- capturingSubstitution tidyUp $ do

7480 (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup (Just moduleName) vals

75− ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict

76− ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict

77− return (map (\x -> (False, x)) ds1 ++ map (\x -> (True, x)) ds2)

81+ ds1 <- parU typed $ \e -> withoutWarnings $ checkTypedBindingGroupElement moduleName e dict

82+ ds2 <- forM untyped $ \e -> withoutWarnings $ typeForBindingGroupElement e dict untypedDict

83+ return (map (False, ) ds1 ++ map (True, ) ds2)

7884

79− inferred <- forM tys $ \(shouldGeneralize, (ident, (val, ty))) -> do

85+ inferred <- forM tys $ \(shouldGeneralize, ((ident, (val, ty)), _)) -> do

8086 -- Replace type class dictionary placeholders with actual dictionaries

8187 (val', unsolved) <- replaceTypeClassDictionaries shouldGeneralize val

8288 -- Generalize and constrain the type

@@ -96,7 +102,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do

96102 $ CannotGeneralizeRecursiveFunction ident generalized

97103 -- Make sure any unsolved type constraints only use type variables which appear

98104 -- unknown in the inferred type.

99− forM_ unsolved $ \(_, con) -> do

105+ forM_ unsolved $ \(_, _, con) -> do

100106 -- We need information about functional dependencies, since we allow

101107 -- ambiguous types to be inferred if they can be solved by some functional

102108 -- dependency.

@@ -104,33 +110,56 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do

104110 TypeClassData{ typeClassDependencies } <- gets (findClass . typeClasses . checkEnv)

105111 let solved = foldMap (S.fromList . fdDetermined) typeClassDependencies

106112 let constraintTypeVars = nub . foldMap (unknownsInType . fst) . filter ((`notElem` solved) . snd) $ zip (constraintArgs con) [0..]

107− when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $

108− throwError . onErrorMessages (replaceTypes currentSubst) . errorMessage $ NoInstanceFound con

113+ when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $ do

114+ throwError . onErrorMessages (replaceTypes currentSubst) . errorMessage $ AmbiguousTypeVariables generalized con

109115

110116 -- Check skolem variables did not escape their scope

111117 skolemEscapeCheck val'

112118 -- Check rows do not contain duplicate labels

113119 checkDuplicateLabels val'

114− return (ident, (foldr (Abs . Left . fst) val' unsolved, generalized))

120+ return ((ident, (foldr (Abs . Left . (\(x, _, _) -> x)) val' unsolved, generalized)), unsolved)

115121

116122 -- Show warnings here, since types in wildcards might have been solved during

117123 -- instance resolution (by functional dependencies).

118− finalSubst <- gets checkSubstitution

119− escalateWarningWhen isHoleError . tell . onErrorMessages (replaceTypes finalSubst) $ w

124+ finalState <- get

125+ forM_ tys $ \(shouldGeneralize, ((_, (_, _)), w)) -> do

126+ let replaceTypes' = replaceTypes (checkSubstitution finalState)

127+ runTypeSearch' = runTypeSearch (guard shouldGeneralize $> foldMap snd inferred) finalState

128+ (escalateWarningWhen isHoleError . tell . onErrorMessages (runTypeSearch' . replaceTypes')) w

120129

121− return inferred

130+ return (map fst inferred)

122131 where

132+ replaceTypes

133+ :: Substitution

134+ -> ErrorMessage

135+ -> ErrorMessage

123136 replaceTypes subst = onTypesInErrorMessage (substituteType subst)

124137

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+

125154 -- | Generalize type vars using forall and add inferred constraints

126155 generalize unsolved = varIfUnknown . constrain unsolved

127156

128157 -- | Add any unsolved constraints

129158 constrain [] = id

130− constrain cs = ConstrainedType (map snd cs)

159+ constrain cs = ConstrainedType (map (\(_, _, x) -> x) cs)

131160

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

134163

135164 isHoleError :: ErrorMessage -> Bool

136165 isHoleError (ErrorMessage _ HoleInferredType{}) = True

@@ -199,19 +228,12 @@ typeForBindingGroupElement (ident, val) dict untypedDict = do

199228-- | Check if a value contains a type annotation

200229isTyped :: (Ident, Expr) -> Either (Ident, Expr) (Ident, (Expr, Type, Bool))

201230isTyped (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))

202235isTyped (name, value) = Left (name, value)

203236

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−

215237-- | Check the kind of a type, failing if it is not of kind *.

216238checkTypeKind ::

217239 (MonadError MultipleErrors m) =>

@@ -339,7 +361,8 @@ infer' (TypedValue checkType val ty) = do

339361infer' (Hole name) = do

340362 ty <- freshType

341363 ctx <- getLocalContext

342− tell . errorMessage $ HoleInferredType name ty ctx

364+ env <- getEnv

365+ tell . errorMessage $ HoleInferredType name ty ctx (TSBefore env)

343366 return $ TypedValue True (Hole name) ty

344367infer' (PositionedValue pos c val) = warnAndRethrowWithPositionTC pos $ do

345368 TypedValue t v ty <- infer' val

@@ -568,18 +591,14 @@ check' (Abs (Right _) _) _ = internalError "Binder was not desugared"

568591check' (App f arg) ret = do

569592 f'@(TypedValue _ _ ft) <- infer f

570593 (retTy, app) <- checkFunctionApplication f' ft arg

571− v' <- subsumes (Just app) retTy ret

572− case v' of

573− Nothing -> internalError "check: unable to check the subsumes relation."

574− Just app' -> return $ TypedValue True app' ret

594+ elaborate <- subsumes retTy ret

595+ return $ TypedValue True (elaborate app) ret

575596check' v@(Var var) ty = do

576597 checkVisibility var

577598 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable $ var

578599 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

579− v' <- subsumes (Just v) repl ty'

580− case v' of

581− Nothing -> internalError "check: unable to check the subsumes relation."

582− Just v'' -> return $ TypedValue True v'' ty'

600+ elaborate <- subsumes repl ty'

601+ return $ TypedValue True (elaborate v) ty'

583602check' (DeferredDictionary className tys) _ = do

584603 {-

585604 -- Here, we replace a placeholder for a superclass dictionary with a regular

@@ -596,12 +615,11 @@ check' (TypedValue checkType val ty1) ty2 = do

596615 checkTypeKind ty1 kind

597616 ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty1

598617 ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2

599− val' <- subsumes (Just val) ty1' ty2'

600− case val' of

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

604− return $ TypedValue checkType val''' ty2'

618+ _ <- subsumes ty1' ty2'

619+ val' <- if checkType

620+ then withScopedTypeVars moduleName args (check val ty2')

621+ else return val

622+ return $ TypedValue checkType val' ty2'

605623check' (Case vals binders) ret = do

606624 (vals', ts) <- instantiateForBinders vals binders

607625 binders' <- checkBinders ts ret binders

@@ -638,10 +656,8 @@ check' v@(Constructor c) ty = do

638656 Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c

639657 Just (_, _, ty1, _) -> do

640658 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

641− mv <- subsumes (Just v) repl ty

642− case mv of

643− Nothing -> internalError "check: unable to check the subsumes relation."

644− Just v' -> return $ TypedValue True v' ty

659+ elaborate <- subsumes repl ty

660+ return $ TypedValue True (elaborate v) ty

645661check' (Let ds val) ty = do

646662 (ds', val') <- inferLetBinding [] ds val (`check` ty)

647663 return $ TypedValue True (Let ds' val') ty

@@ -654,10 +670,8 @@ check' (PositionedValue pos c val) ty = warnAndRethrowWithPositionTC pos $ do

654670 return $ TypedValue t (PositionedValue pos c v) ty'

655671check' val ty = do

656672 TypedValue _ val' ty' <- infer val

657− mt <- subsumes (Just val') ty' ty

658− case mt of

659− Nothing -> internalError "check: unable to check the subsumes relation."

660− Just v' -> return $ TypedValue True v' ty

673+ elaborate <- subsumes ty' ty

674+ return $ TypedValue True (elaborate val') ty

661675

662676-- |

663677-- Check the type of a collection of named record fields

src/System/IO/UTF8.hs+12−2

@@ -4,11 +4,21 @@ import Prelude.Compat

55import qualified Data.ByteString as BS

66import qualified Data.ByteString.UTF8 as UTF8

7+import Data.Text (Text)

8+import qualified Data.Text.Encoding as TE

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)

717

818readUTF8File :: FilePath -> IO String

9−readUTF8File inFile = do

19+readUTF8File inFile =

1020 fmap UTF8.toString (BS.readFile inFile)

1121

1222writeUTF8File :: FilePath -> String -> IO ()

13−writeUTF8File inFile text = do

23+writeUTF8File inFile text =

1424 BS.writeFile inFile (UTF8.fromString text)

stack.yaml+1−10

@@ -1,12 +1,3 @@

1−resolver: lts-6.13

1+resolver: lts-6.10

22packages:

33- '.'

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

99import Test.Hspec

1010

1111value :: 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))

1313

1414moduleA, moduleB :: Module

1515moduleA = (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

66import Protolude

88import qualified Data.Text as T

9−import qualified Data.Text.IO as TIO

109import qualified Language.PureScript.Ide.Integration as Integration

1110import Test.Hspec

1211

1312import System.Directory

1413import System.FilePath

14+import System.IO.UTF8 (readUTF8FileT)

1515

1616setup :: IO ()

1717setup = void (Integration.reset *> Integration.loadAll)

@@ -27,7 +27,7 @@ withSupportFiles test = do

2727outputFileShouldBe :: [Text] -> IO ()

2828outputFileShouldBe expectation = do

2929 outFp <- (</> "src" </> "ImportsSpecOut.tmp") <$> Integration.projectDirectory

30− outRes <- TIO.readFile outFp

30+ outRes <- readUTF8FileT outFp

3131 shouldBe (T.lines outRes) expectation

3232

3333spec :: Spec

@@ -57,10 +57,10 @@ spec = beforeAll_ setup . describe "Adding imports" $ do

5757 outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (class ATypeClass)"])

5858 it "adds an explicit unqualified import (dataconstructor)" $ do

5959 withSupportFiles (Integration.addImport "MyJust")

60− outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyMaybe(MyJust))"])

60+ outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyMaybe(..))"])

6161 it "adds an explicit unqualified import (newtype)" $ do

6262 withSupportFiles (Integration.addImport "MyNewtype")

63− outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyNewtype(MyNewtype))"])

63+ outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyNewtype(..))"])

6464 it "adds an explicit unqualified import (typeclass member function)" $ do

6565 withSupportFiles (Integration.addImport "typeClassFun")

6666 outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (typeClassFun)"])

tests/Language/PureScript/Ide/ImportsSpec.hs+49−6

@@ -68,11 +68,13 @@ spec = do

6868 describe "import commands" $ do

6969 let simpleFileImports = let (_, _, i, _) = splitSimpleFile in i

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

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

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

7678 it "adds an implicit unqualified import" $

7779 shouldBe

7880 (addImplicitImport' simpleFileImports (P.moduleNameFromString "Data.Map"))

@@ -100,20 +102,26 @@ spec = do

100102 shouldBe

101103 (addOpImport (P.OpName "<~>") (P.moduleNameFromString "Data.Array") explicitImports)

102104 [ "import Prelude"

103− , "import Data.Array ((<~>), tail)"

105+ , "import Data.Array (tail, (<~>))"

104106 ]

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+ ]

105113 it "adds the type for a given DataConstructor" $

106114 shouldBe

107115 (addDtorImport "Just" (P.ProperName "Maybe") (P.moduleNameFromString "Data.Maybe") simpleFileImports)

108116 [ "import Prelude"

109− , "import Data.Maybe (Maybe(Just))"

117+ , "import Data.Maybe (Maybe(..))"

110118 ]

111119 it "adds a dataconstructor to an existing type import" $ do

112120 let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe)"])

113121 shouldBe

114122 (addDtorImport "Just" (P.ProperName "Maybe") (P.moduleNameFromString "Data.Maybe") typeImports)

115123 [ "import Prelude"

116− , "import Data.Maybe (Maybe(Just))"

124+ , "import Data.Maybe (Maybe(..))"

117125 ]

118126 it "doesn't add a dataconstructor to an existing type import with open dtors" $ do

119127 let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe(..))"])

@@ -128,3 +136,38 @@ spec = do

128136 [ "import Prelude"

129137 , "import Data.Array (tail)"

130138 ]

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

1313import Test.Hspec

1414

1515value :: 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))

1717

1818firstResult, secondResult, fiult :: Match IdeDeclarationAnn

1919firstResult = Match (P.moduleNameFromString "Match", value "firstResult")

tests/Language/PureScript/Ide/ReexportsSpec.hs+5−5

@@ -18,11 +18,11 @@ d :: IdeDeclaration -> IdeDeclarationAnn

1818d = IdeDeclarationAnn emptyAnn

1919

2020valueA, typeA, classA, dtorA1, dtorA2 :: IdeDeclarationAnn

21−valueA = d (IdeValue (P.Ident "valueA") P.REmpty)

22−typeA = d (IdeType (P.ProperName "TypeA") P.Star)

23−classA = d (IdeTypeClass (P.ProperName "ClassA"))

24−dtorA1 = d (IdeDataConstructor (P.ProperName "DtorA1") (P.ProperName "TypeA") P.REmpty)

25−dtorA2 = d (IdeDataConstructor (P.ProperName "DtorA2") (P.ProperName "TypeA") P.REmpty)

21+valueA = d (IdeDeclValue (IdeValue (P.Ident "valueA") P.REmpty))

22+typeA = d (IdeDeclType (IdeType(P.ProperName "TypeA") P.Star))

23+classA = d (IdeDeclTypeClass (P.ProperName "ClassA"))

24+dtorA1 = d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "DtorA1") (P.ProperName "TypeA") P.REmpty))

25+dtorA2 = d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "DtorA2") (P.ProperName "TypeA") P.REmpty))

2626

2727env :: Map P.ModuleName [IdeDeclarationAnn]

2828env = Map.fromList

tests/Language/PureScript/Ide/StateSpec.hs+6−6

@@ -11,20 +11,20 @@ import qualified Data.Map as Map

1111

1212valueOperator :: Maybe P.Type -> IdeDeclarationAnn

1313valueOperator =

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

1515

1616ctorOperator :: Maybe P.Type -> IdeDeclarationAnn

1717ctorOperator =

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

1919

2020typeOperator :: Maybe P.Kind -> IdeDeclarationAnn

2121typeOperator =

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

2323

2424testModule :: Module

25−testModule = (mn "Test", [ d (IdeValue (P.Ident "function") P.REmpty)

26− , d (IdeDataConstructor (P.ProperName "Cons") (P.ProperName "List") (P.REmpty))

27− , d (IdeType (P.ProperName "List") P.Star)

25+testModule = (mn "Test", [ d (IdeDeclValue (IdeValue (P.Ident "function") P.REmpty))

26+ , d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "Cons") (P.ProperName "List") (P.REmpty)))

27+ , d (IdeDeclType (IdeType (P.ProperName "List") P.Star))

2828 , valueOperator Nothing

2929 , ctorOperator Nothing

3030 , typeOperator Nothing

tests/TestCompiler.hs+3−2

@@ -31,6 +31,7 @@ import Data.List (sort, stripPrefix, intercalate, groupBy, sortBy, minimumBy)

3131import Data.Maybe (mapMaybe)

3232import Data.Time.Clock (UTCTime())

3333import Data.Tuple (swap)

34+import qualified Data.Text as T

3435

3536import qualified Data.Map as M

3637

@@ -71,7 +72,7 @@ spec = do

7172 supportPurs <- supportFiles "purs"

7273 supportPursFiles <- readInput supportPurs

7374 supportExterns <- runExceptT $ do

74− modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles

75+ modules <- ExceptT . return $ P.parseModulesFromFiles id (map (fmap T.pack) supportPursFiles)

7576 foreigns <- inferForeignModules modules

7677 externs <- ExceptT . fmap fst . runTest $ P.make (makeActions foreigns) (map snd modules)

7778 return (zip (map snd modules) externs)

@@ -194,7 +195,7 @@ compile

194195 -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors)

195196compile supportExterns inputFiles check = silence $ runTest $ do

196197 fs <- liftIO $ readInput inputFiles

197− ms <- P.parseModulesFromFiles id fs

198+ ms <- P.parseModulesFromFiles id (map (fmap T.pack) fs)

198199 foreigns <- inferForeignModules ms

199200 liftIO (check (map snd ms))

200201 let actions = makeActions foreigns

tests/TestUtils.hs+27−5

@@ -53,16 +53,24 @@ updateSupportCode = do

5353--

5454supportModules :: [String]

5555supportModules =

56− [ "Control.Applicative"

56+ [ "Control.Alt"

57+ , "Control.Alternative"

58+ , "Control.Applicative"

5759 , "Control.Apply"

5860 , "Control.Bind"

5961 , "Control.Category"

62+ , "Control.Comonad"

63+ , "Control.Extend"

64+ , "Control.Lazy"

65+ , "Control.Monad"

66+ , "Control.Monad.Eff"

6067 , "Control.Monad.Eff.Class"

6168 , "Control.Monad.Eff.Console"

6269 , "Control.Monad.Eff.Unsafe"

63− , "Control.Monad.Eff"

6470 , "Control.Monad.ST"

65− , "Control.Monad"

71+ , "Control.MonadPlus"

72+ , "Control.MonadZero"

73+ , "Control.Plus"

6674 , "Control.Semigroupoid"

6775 , "Data.Boolean"

6876 , "Data.BooleanAlgebra"

@@ -71,14 +79,27 @@ supportModules =

7179 , "Data.Eq"

7280 , "Data.EuclideanRing"

7381 , "Data.Field"

74− , "Data.Function.Uncurried"

7582 , "Data.Function"

83+ , "Data.Function.Uncurried"

7684 , "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"

7791 , "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"

7899 , "Data.NaturalTransformation"

79100 , "Data.Newtype"

80− , "Data.Ord.Unsafe"

81101 , "Data.Ord"

102+ , "Data.Ord.Unsafe"

82103 , "Data.Ordering"

83104 , "Data.Ring"

84105 , "Data.Semigroup"

@@ -90,6 +111,7 @@ supportModules =

90111 , "Partial.Unsafe"

91112 , "Prelude"

92113 , "Test.Assert"

114+ , "Test.Main"

93115 ]

94116

95117pushd :: forall a. FilePath -> IO a -> IO a

tests/support/bower.json+2−1

@@ -8,6 +8,7 @@

88 "purescript-prelude": "1.1.0",

99 "purescript-st": "1.0.0-rc.1",

1010 "purescript-partial": "1.1.2",

11− "purescript-newtype": "0.1.0"

11+ "purescript-newtype": "0.1.0",

12+ "purescript-generics-rep": "2.0.0"

1213 }

1314}