packages feed

purescript 0.10.1 → 0.10.2

raw patch · 79 files changed

+1700/−756 lines, 79 filesdep +aeson-prettydep +foldldep +lensdep ~aesondep ~basedep ~clocknew-component:exe:psc-package

Dependencies added: aeson-pretty, foldl, lens, system-filepath, turtle

Dependency ranges changed: aeson, base, clock, http-client, optparse-applicative

Files

CONTRIBUTORS.md view
@@ -63,6 +63,7 @@ - [@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). - [@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). - [@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).+- [@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). - [@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). - [@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). - [@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 @@ - [@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). - [@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. - [@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).+- [@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).+- [@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).  ### Companies
+ examples/failing/2378.purs view
@@ -0,0 +1,6 @@+-- @shouldFailWith OrphanInstance+module Main where++import Lib++instance fooX :: Foo "x"
+ examples/failing/2378/Lib.purs view
@@ -0,0 +1,3 @@+module Lib (class Foo) where++class Foo (a :: Symbol)
+ examples/failing/2379.purs view
@@ -0,0 +1,6 @@+-- @shouldFailWith UnknownClass+module Main where++import Lib++test = x [1, 2, 3]
+ examples/failing/2379/Lib.purs view
@@ -0,0 +1,9 @@+module Lib (class X, x) where++class X a where+  x :: a -> String++class Y a++instance xArray :: Y a => X (Array a) where+  x _ = "[]"
+ examples/failing/ConstraintFailure.purs view
@@ -0,0 +1,13 @@+-- @shouldFailWith NoInstanceFound++module Main where++import Prelude++data Foo = Bar+       +spin :: forall a. a -> Foo+spin x = Bar++main = show <<< spin+
examples/failing/ConstraintInference.purs view
@@ -1,4 +1,4 @@--- @shouldFailWith NoInstanceFound+-- @shouldFailWith AmbiguousTypeVariables  module Main where
examples/failing/NonWildcardNewtypeInstance.purs view
@@ -1,4 +1,4 @@--- @shouldFailWith NonWildcardNewtypeInstance+-- @shouldFailWith ExpectedWildcard module NonWildcardNewtypeInstance where  import Data.Newtype
+ examples/passing/2378.purs view
@@ -0,0 +1,9 @@+module Main where++import Control.Monad.Eff.Console (log)++class Foo (a :: Symbol)++instance fooX :: Foo "x"++main = log "Done"
+ examples/passing/DctorName.purs view
@@ -0,0 +1,33 @@+module Main where++import Prelude+import Control.Monad.Eff.Console (log)++newtype Bar' = Bar' Int++data Foo' = Foo' Bar'++data Baz'' = Baz'' | Baz'++f ∷ Foo' → Boolean+f a = case a of Foo' b → true++f' ∷ Boolean+f' = f $ Foo' $ Bar' 0++g ∷ Baz'' → Int+g Baz'' = 0+g Baz' = 1++g' ∷ Int+g' = g Baz''++h ∷ Bar' → Int+h (Bar' x)+ | x <= 10 = x * 2 + | otherwise = 10++h' ∷ Int+h' = h $ Bar' 4++main = log "Done"
− examples/passing/GHCGenerics.purs 
@@ -1,140 +0,0 @@--- An example to show how we could implement GHC-style Generics using--- functional dependencies.------ See https://hackage.haskell.org/package/base-4.9.0.0/docs/GHC-Generics.html--module Main where--import Prelude-import Control.Monad.Eff (Eff)-import Control.Monad.Eff.Console (CONSOLE, log, logShow)---- Representation for types with no constructors-data V1---- Representation for constructors with no arguments-data U1 = U1---- Representation for sum types-data Sum a b = Inl a | Inr b--infixr 5 type Sum as +---- Representation for product types-data Product a b = Product a b--infixr 6 type Product as *---- Representation for data constructors, with the data constructor name indicated--- at the type level.-data Ctor (name :: Symbol) a = Ctor a---- Representation for occurrences of other types in a data type definition.-data K a = K a---- The Generic class asserts the existence of a type function from "real" types--- to representation types, and an isomorphism between them.-class Generic a repr | a -> repr where-  to :: a -> repr-  from :: repr -> a---- We can write an instance for the (recursive) type of lists. Note that these--- instances would be generated by the compiler ideally.-data List a = Nil | Cons a (List a)--instance genericList :: Generic (List a) (Ctor "Nil" U1 + Ctor "Cons" (K a * K (List a))) where-  to Nil = Inl (Ctor U1)-  to (Cons x xs) = Inr (Ctor (Product (K x) (K xs)))-  from (Inl (Ctor U1)) = Nil-  from (Inr (Ctor (Product (K x) (K xs)))) = Cons x xs---- We'd like to refect type level strings (for data constructor names) at the value--- level, so that we can "show" them. Again, these instances would ideally be derived--- for us.-class KnownSymbol (sym :: Symbol) where-  symbol :: forall proxy. proxy sym -> String--instance knownSymbolNil :: KnownSymbol "Nil" where-  symbol _ = "Nil"--instance knownSymbolCons :: KnownSymbol "Cons" where-  symbol _ = "Cons"---- A proxy for a type-level string.-data SProxy (sym :: Symbol) = SProxy---- To write generic functions, we create a corresponding type class, and use the--- type class machinery to infer the correct function based on the representation--- type.-class GShow a where-  gShow :: a -> String---- Now provide instances for GShow for the appropriate representation types.--- Note: we don't have to implement all instances here.--instance gShowU1 :: GShow U1 where-  gShow _ = ""--instance gShowSum :: (GShow a, GShow b) => GShow (a + b) where-  gShow (Inl a) = gShow a-  gShow (Inr b) = gShow b--instance gShowProduct :: (GShow a, GShow b) => GShow (a * b) where-  gShow (Product a b) = gShow a <> gShow b--instance gShowCtor :: (KnownSymbol ctor, GShow a) => GShow (Ctor ctor a) where-  gShow (Ctor a) = "(" <> symbol (SProxy :: SProxy ctor) <> gShow a <> ")"--instance gShowK :: Show a => GShow (K a) where-  gShow (K a) = " " <> show a---- Now we can implement a generic show function which uses the GShow instance--- on the representation type.-genericShow :: forall a repr. (Generic a repr, GShow repr) => a -> String-genericShow x = gShow (to x)---- Note how the required instance here is Show a, and not Generic a.--- This allows us to use generic programming on a wider variety of types--- (including types which contain foreign types) than we can use now.-instance showList :: Show a => Show (List a) where-  show xs = genericShow xs -- (we need to eta expand here to avoid stack overflow-                           -- due to recursion implicit in the instance lookup)---- Another example: Eq--class GEq a where-  gEq :: a -> a -> Boolean--instance gEqU1 :: GEq U1 where-  gEq _ _ = true--instance gEqSum :: (GEq a, GEq b) => GEq (a + b) where-  gEq (Inl a1) (Inl a2) = gEq a1 a2-  gEq (Inr b1) (Inr b2) = gEq b1 b2-  gEq _ _ = false--instance gEqProduct :: (GEq a, GEq b) => GEq (a * b) where-  gEq (Product a1 b1) (Product a2 b2) = gEq a1 a2 && gEq b1 b2--instance gEqCtor :: (KnownSymbol ctor, GEq a) => GEq (Ctor ctor a) where-  gEq (Ctor a1) (Ctor a2) = gEq a1 a2--instance gEqK :: Eq a => GEq (K a) where-  gEq (K a1) (K a2) = a1 == a2--genericEq :: forall a repr. (Generic a repr, GEq repr) => a -> a -> Boolean-genericEq x y = gEq (to x) (to y)--instance eqList :: Eq a => Eq (List a) where-  eq xs ys = genericEq xs ys--main :: Eff (console :: CONSOLE) Unit-main = do-  logShow (Cons 1 Nil)-  logShow (Cons 1 (Cons 2 Nil))-  logShow (Cons 'x' (Cons 'y' (Cons 'z' Nil)))--  logShow (Cons 1 (Cons 2 Nil) == Cons 1 (Cons 2 Nil))-  logShow (Cons 1 (Cons 2 Nil) == Cons 1 Nil)--  log "Done"
+ examples/passing/GenericsRep.purs view
@@ -0,0 +1,53 @@+module Main where++import Prelude+import Control.Monad.Eff (Eff)+import Control.Monad.Eff.Console (CONSOLE, log, logShow)+import Data.Generic.Rep (class Generic)+import Data.Generic.Rep.Eq (genericEq)++data X a = X a +	 +derive instance genericX :: Generic (X a) _++instance eqX :: Eq a => Eq (X a) where+  eq xs ys = genericEq xs ys++data Y a = Y | Z a (Y a)++derive instance genericY :: Generic (Y a) _++instance eqY :: Eq a => Eq (Y a) where+  eq xs ys = genericEq xs ys++data Z++derive instance genericZ :: Generic Z _++instance eqZ :: Eq Z where+  eq x y = genericEq x y++newtype W = W { x :: Int, y :: String }++derive instance genericW :: Generic W _++instance eqW :: Eq W where+  eq x y = genericEq x y++data V = V { x :: Int } { x :: Int }+ +derive instance genericV :: Generic V _++instance eqV :: Eq V where+  eq x y = genericEq x y++main :: Eff (console :: CONSOLE) Unit+main = do+  logShow (X 0 == X 1)+  logShow (X 1 == X 1)+  logShow (Z 1 Y == Z 1 Y)+  logShow (Z 1 Y == Y)+  logShow (Y == Y :: Y Z)+  logShow (W { x: 0, y: "A" } == W { x: 0, y: "A" })+  logShow (V { x: 0 } { x: 0 } == V { x: 0 } { x: 0 })+  log "Done"
+ examples/passing/RowsInInstanceContext.purs view
@@ -0,0 +1,25 @@+module Main where++import Prelude+import Control.Monad.Eff (Eff)+import Control.Monad.Eff.Console (CONSOLE, log)+import Data.Newtype (class Newtype, unwrap)++class TypeEquals a b | a -> b, b -> a where+  coerce :: a -> b+  coerceBack :: b -> a++instance refl :: TypeEquals a a where+  coerce = id+  coerceBack = id++newtype RecordNewtype = RecordNewtype { x :: String }++instance newtypeRecordNewtype ::+  TypeEquals inner { x :: String }+    => Newtype RecordNewtype inner where+  wrap = RecordNewtype <<< coerce+  unwrap (RecordNewtype rec) = coerceBack rec++main :: Eff (console :: CONSOLE) Unit+main = log (unwrap (RecordNewtype { x: "Done" })).x
+ examples/warning/2383.purs view
@@ -0,0 +1,12 @@+-- | This specifically shouldn't warn about `x` being shadowed in `main`+-- | See https://github.com/purescript/purescript/issues/2383+module Main where++import Prelude++import Control.Monad.Eff (Eff)++main :: Eff () Unit+main = do+  x <- let x = pure unit in x+  pure unit
+ examples/warning/2411.purs view
@@ -0,0 +1,15 @@+-- @shouldWarnWith ShadowedName+module Main where++import Prelude++import Control.Monad.Eff (Eff)++test :: forall m. Monad m => Int -> m Unit+test x =+  let x = unit+  in pure x++main :: Eff () Unit+main = test 42+
hierarchy/Main.hs view
@@ -33,7 +33,7 @@ import System.FilePath.Glob (glob) import System.Exit (exitFailure, exitSuccess) import System.IO (hPutStr, stderr)-import System.IO.UTF8 (readUTF8File)+import System.IO.UTF8 (readUTF8FileT)  import qualified Language.PureScript as P import qualified Paths_purescript as Paths@@ -60,7 +60,7 @@  readInput :: [FilePath] -> IO (Either P.MultipleErrors [P.Module]) readInput paths = do-  content <- mapM (\path -> (path, ) <$> readUTF8File path) paths+  content <- mapM (\path -> (path, ) <$> readUTF8FileT path) paths   return $ map snd <$> P.parseModulesFromFiles id content  compile :: HierarchyOptions -> IO ()
psc-docs/Main.hs view
@@ -7,6 +7,7 @@ import Control.Arrow (first, second) import Control.Category ((>>>)) import Control.Monad.Writer+import Data.Text (Text) import Data.Function (on) import Data.List import Data.Maybe (fromMaybe)@@ -20,7 +21,7 @@ import qualified Paths_purescript as Paths import System.Exit (exitFailure) import System.IO (hPutStrLn, hPrint, hSetEncoding, stderr, stdout, utf8)-import System.IO.UTF8 (readUTF8File)+import System.IO.UTF8 (readUTF8FileT) import System.Directory (createDirectoryIfMissing) import System.FilePath (takeDirectory) import System.FilePath.Glob (glob)@@ -139,8 +140,8 @@   ldump :: [String] -> IO ()   ldump = mapM_ putStrLn -parseFile :: FilePath -> IO (FilePath, String)-parseFile input = (,) input <$> readUTF8File input+parseFile :: FilePath -> IO (FilePath, Text)+parseFile input = (,) input <$> readUTF8FileT input  inputFile :: Parser FilePath inputFile = strArgument $@@ -235,16 +236,16 @@   PP.vcat $ map PP.text     [ "Examples:"     , "  print documentation for Data.List to stdout:"-    , "    psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\"+    , "    psc-docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\"     , "      --docgen Data.List"     , ""     , "  write documentation for Data.List to docs/Data.List.md:"-    , "    psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\"+    , "    psc-docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\"     , "      --docgen Data.List:docs/Data.List.md"     , ""     , "  write documentation for Data.List to docs/Data.List.md, and"     , "  documentation for Data.List.Lazy to docs/Data.List.Lazy.md:"-    , "    psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\"+    , "    psc-docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\"     , "      --docgen Data.List:docs/Data.List.md \\"     , "      --docgen Data.List.Lazy:docs/Data.List.Lazy.md"     ]
+ psc-package/Main.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}++module Main where++import qualified Data.Aeson as Aeson+import           Data.Aeson.Encode.Pretty+import           Data.Foldable (fold, for_, traverse_)+import           Data.List (nub)+import qualified Data.Map as Map+import           Data.Maybe (mapMaybe)+import qualified Data.Set as Set+import           Data.Text (pack)+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TB+import           Data.Text.Encoding (encodeUtf8)+import           Data.Traversable (for)+import           Data.Version (showVersion)+import qualified Filesystem.Path.CurrentOS as Path+import           GHC.Generics (Generic)+import qualified Options.Applicative as Opts+import qualified Paths_purescript as Paths+import qualified System.IO as IO+import           Turtle hiding (fold)++packageFile :: Path.FilePath+packageFile = "psc-package.json"++data PackageConfig = PackageConfig+  { name    :: Text+  , depends :: [Text]+  , set     :: Text+  , source  :: Text+  } deriving (Show, Generic, Aeson.FromJSON, Aeson.ToJSON)++pathToTextUnsafe :: Turtle.FilePath -> Text+pathToTextUnsafe = either (error "Path.toText failed") id . Path.toText++defaultPackage :: Text -> PackageConfig+defaultPackage pkgName =+  PackageConfig { name    = pkgName+                , depends = [ "prelude" ]+                , set     = "psc-" <> pack (showVersion Paths.version)+                , source  = "https://github.com/purescript/package-sets.git"+                }++readPackageFile :: IO PackageConfig+readPackageFile = do+  exists <- testfile packageFile+  unless exists $ do+    echo "psc-package.json does not exist"+    exit (ExitFailure 1)+  mpkg <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile packageFile+  case mpkg of+    Nothing -> do+      echo "Unable to parse psc-package.json"+      exit (ExitFailure 1)+    Just pkg -> return pkg++encodePrettyToText :: Aeson.ToJSON json => json -> Text+encodePrettyToText =+    TL.toStrict+    . TB.toLazyText+    . encodePrettyToTextBuilder' config+  where+    config = defConfig+               { confCompare =+                   keyOrder [ "name"+                            , "set"+                            , "source"+                            , "depends"+                            ]+               }++writePackageFile :: PackageConfig -> IO ()+writePackageFile =+  writeTextFile packageFile+  . encodePrettyToText++data PackageInfo = PackageInfo+  { repo         :: Text+  , version      :: Text+  , dependencies :: [Text]+  } deriving (Show, Eq, Generic, Aeson.FromJSON, Aeson.ToJSON)++type PackageSet = Map.Map Text PackageInfo++cloneShallow+  :: Text+  -- ^ repo+  -> Text+  -- ^ branch/tag+  -> Turtle.FilePath+  -- ^ target directory+  -> IO ExitCode+cloneShallow from ref into =+  proc "git"+       [ "clone"+       , "-q"+       , "-c", "advice.detachedHead=false"+       , "--depth", "1"+       , "-b", ref+       , from+       , pathToTextUnsafe into+       ] empty .||. exit (ExitFailure 1)++getPackageSet :: PackageConfig -> IO ()+getPackageSet PackageConfig{ source, set } = do+  let pkgDir = ".psc-package" </> fromText set </> ".set"+  exists <- testdir pkgDir+  unless exists . void $ cloneShallow source set pkgDir++readPackageSet :: PackageConfig -> IO PackageSet+readPackageSet PackageConfig{ set } = do+  let dbFile = ".psc-package" </> fromText set </> ".set" </> "packages.json"+  exists <- testfile dbFile+  unless exists $ do+    echo "packages.json does not exist"+    exit (ExitFailure 1)+  mdb <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile dbFile+  case mdb of+    Nothing -> do+      echo "Unable to parse packages.json"+      exit (ExitFailure 1)+    Just db -> return db++installOrUpdate :: PackageConfig -> Text -> PackageInfo -> IO ()+installOrUpdate PackageConfig{ set } pkgName PackageInfo{ repo, version } = do+  let pkgDir = ".psc-package" </> fromText set </> fromText pkgName </> fromText version+  exists <- testdir pkgDir+  unless exists . void $ cloneShallow repo version pkgDir++getTransitiveDeps :: PackageSet -> [Text] -> IO [(Text, PackageInfo)]+getTransitiveDeps db depends = do+  pkgs <- for depends $ \pkg ->+    case Map.lookup pkg db of+      Nothing -> do+        echo ("Package " <> pkg <> " does not exist in package set")+        exit (ExitFailure 1)+      Just PackageInfo{ dependencies } -> return (pkg : dependencies)+  let unique = Set.toList (foldMap Set.fromList pkgs)+  return (mapMaybe (\name -> fmap (name, ) (Map.lookup name db)) unique)++updateImpl :: PackageConfig -> IO ()+updateImpl config@PackageConfig{ depends } = do+  getPackageSet config+  db <- readPackageSet config+  trans <- getTransitiveDeps db depends+  echo ("Updating " <> pack (show (length trans)) <> " packages...")+  for_ trans $ \(pkgName, pkg) -> do+    echo ("Updating " <> pkgName)+    installOrUpdate config pkgName pkg++initialize :: IO ()+initialize = do+  exists <- testfile "psc-package.json"+  when exists $ do+    echo "psc-package.json already exists"+    exit (ExitFailure 1)+  echo "Initializing new project in current directory"+  pkgName <- pathToTextUnsafe . Path.filename <$> pwd+  let pkg = defaultPackage pkgName+  writePackageFile pkg+  updateImpl pkg++update :: IO ()+update = do+  pkg <- readPackageFile+  updateImpl pkg+  echo "Update complete"++install :: String -> IO ()+install pkgName = do+  pkg <- readPackageFile+  let pkg' = pkg { depends = nub (pack pkgName : depends pkg) }+  updateImpl pkg'+  writePackageFile pkg'+  echo "psc-package.json file was updated"++listDependencies :: IO ()+listDependencies = do+  pkg@PackageConfig{ depends } <- readPackageFile+  db <- readPackageSet pkg+  trans <- getTransitiveDeps db depends+  traverse_ (echo . fst) trans++getSourcePaths :: PackageConfig -> PackageSet -> [Text] -> IO [Turtle.FilePath]+getSourcePaths PackageConfig{..} db pkgNames = do+  trans <- getTransitiveDeps db pkgNames+  let paths = [ ".psc-package"+                </> fromText set+                </> fromText pkgName+                </> fromText version+                </> "src" </> "**" </> "*.purs"+              | (pkgName, PackageInfo{ version }) <- trans+              ]+  return paths++listSourcePaths :: IO ()+listSourcePaths = do+  pkg@PackageConfig{ depends } <- readPackageFile+  db <- readPackageSet pkg+  paths <- getSourcePaths pkg db depends+  traverse_ (echo . pathToTextUnsafe) paths++exec :: Text -> IO ()+exec exeName = do+  pkg@PackageConfig{..} <- readPackageFile+  db <- readPackageSet pkg+  paths <- getSourcePaths pkg db depends+  procs exeName+        (map pathToTextUnsafe ("src" </> "**" </> "*.purs" : paths))+        empty++main :: IO ()+main = do+    IO.hSetEncoding IO.stdout IO.utf8+    IO.hSetEncoding IO.stderr IO.utf8+    cmd <- Opts.execParser opts+    cmd+  where+    opts        = Opts.info (versionInfo <*> Opts.helper <*> commands) infoModList+    infoModList = Opts.fullDesc <> headerInfo <> footerInfo+    headerInfo  = Opts.progDesc "Manage package dependencies"+    footerInfo  = Opts.footer $ "psc-package " ++ showVersion Paths.version++    versionInfo :: Parser (a -> a)+    versionInfo = Opts.abortOption (Opts.InfoMsg (showVersion Paths.version)) $+      Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden++    commands :: Parser (IO ())+    commands = (Opts.subparser . fold)+        [ Opts.command "init"+            (Opts.info (pure initialize)+            (Opts.progDesc "Initialize a new package"))+        , Opts.command "update"+            (Opts.info (pure update)+            (Opts.progDesc "Update dependencies"))+        , Opts.command "install"+            (Opts.info (install <$> pkg)+            (Opts.progDesc "Install the named package"))+        , Opts.command "build"+            (Opts.info (pure (exec "psc"))+            (Opts.progDesc "Build the current package and dependencies"))+        , Opts.command "dependencies"+            (Opts.info (pure listDependencies)+            (Opts.progDesc "List all (transitive) dependencies for the current package"))+        , Opts.command "sources"+            (Opts.info (pure listSourcePaths)+            (Opts.progDesc "List all (active) source paths for dependencies"))+        ]+      where+        pkg = Opts.strArgument $+             Opts.metavar "PACKAGE"+          <> Opts.help "The name of the package to install"
psc/Main.hs view
@@ -15,6 +15,7 @@ import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.UTF8 as BU8 import qualified Data.Map as M+import           Data.Text (Text) import           Data.Version (showVersion)  import qualified Language.PureScript as P@@ -29,7 +30,7 @@ import           System.Exit (exitSuccess, exitFailure) import           System.FilePath.Glob (glob) import           System.IO (hSetEncoding, hPutStrLn, stdout, stderr, utf8)-import           System.IO.UTF8+import           System.IO.UTF8 (readUTF8FileT)  data PSCMakeOptions = PSCMakeOptions   { pscmInput        :: [FilePath]@@ -85,8 +86,8 @@     return paths   concatMapM f = fmap concat . mapM f -readInput :: [FilePath] -> IO [(FilePath, String)]-readInput inputFiles = forM inputFiles $ \inFile -> (inFile, ) <$> readUTF8File inFile+readInput :: [FilePath] -> IO [(FilePath, Text)]+readInput inputFiles = forM inputFiles $ \inFile -> (inFile, ) <$> readUTF8FileT inFile  inputFile :: Parser FilePath inputFile = strArgument $
psci/Main.hs view
@@ -63,17 +63,10 @@  -- | Command line options data PSCiOptions = PSCiOptions-  { psciMultiLineMode     :: Bool-  , psciInputFile         :: [FilePath]+  { psciInputFile         :: [FilePath]   , psciBackend           :: Backend   } -multiLineMode :: Opts.Parser Bool-multiLineMode = Opts.switch $-     Opts.long "multi-line-mode"-  <> Opts.short 'm'-  <> Opts.help "Run in multi-line mode (use ^D to terminate commands)"- inputFile :: Opts.Parser FilePath inputFile = Opts.strArgument $      Opts.metavar "FILE"@@ -100,8 +93,7 @@   <|> (nodeBackend <$> nodeFlagsFlag)  psciOptions :: Opts.Parser PSCiOptions-psciOptions = PSCiOptions <$> multiLineMode-                          <*> many inputFile+psciOptions = PSCiOptions <$> many inputFile                           <*> backend  version :: Opts.Parser (a -> a)@@ -119,17 +111,20 @@       footerInfo  = Opts.footer $ "psci " ++ showVersion Paths.version  -- | Parses the input and returns either a command, or an error as a 'String'.-getCommand :: forall m. MonadException m => Bool -> InputT m (Either String (Maybe Command))-getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do-  firstLine <- withInterrupt $ getInputLine "> "-  case firstLine of+getCommand :: forall m. MonadException m => InputT m (Either String (Maybe Command))+getCommand = handleInterrupt (return (Right Nothing)) $ do+  line <- withInterrupt $ getInputLine "> "+  case line of     Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty     Just "" -> return (Right Nothing)-    Just s | singleLineMode || head s == ':' -> return . fmap Just $ parseCommand s-    Just s -> fmap Just . parseCommand <$> go [s]+    Just s  -> return . fmap Just $ parseCommand s++pasteMode :: forall m. MonadException m => InputT m (Either String Command)+pasteMode =+    parseCommand <$> go []   where     go :: [String] -> InputT m String-    go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine "  "+    go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine "… "  -- | Make a JavaScript bundle for the browser. bundle :: IO (Either Bundle.ErrorMessage String)@@ -349,16 +344,28 @@                      go :: state -> InputT (StateT PSCiState (ReaderT PSCiConfig IO)) ()                     go state = do-                      c <- getCommand (not psciMultiLineMode)+                      c <- getCommand                       case c of                         Left err -> outputStrLn err >> go state                         Right Nothing -> go state+                        Right (Just PasteLines) -> do+                          c' <- pasteMode+                          case c' of+                            Left err -> outputStrLn err >> go state+                            Right c'' -> handleCommandWithInterrupts state c''                         Right (Just QuitPSCi) -> do                           outputStrLn quitMessage                           liftIO $ shutdown state-                        Right (Just c') -> do-                          handleInterrupt (outputStrLn "Interrupted.")-                                          (withInterrupt (lift (handleCommand (liftIO . eval state) (liftIO (reload state)) c')))-                          go state+                        Right (Just c') -> handleCommandWithInterrupts state c'++                    handleCommandWithInterrupts+                      :: state+                      -> Command+                      -> InputT (StateT PSCiState (ReaderT PSCiConfig IO)) ()+                    handleCommandWithInterrupts state cmd = do+                      handleInterrupt (outputStrLn "Interrupted.")+                                      (withInterrupt (lift (handleCommand (liftIO . eval state) (liftIO (reload state)) cmd)))+                      go state+                 putStrLn prologueMessage                 setup >>= runner . go
purescript.cabal view
@@ -1,5 +1,5 @@ name: purescript-version: 0.10.1+version: 0.10.2 cabal-version: >=1.8 build-type: Simple license: BSD3@@ -55,6 +55,8 @@                   , examples/passing/TypeWithoutParens/*.purs                   , examples/failing/*.purs                   , examples/failing/1733/*.purs+                  , examples/failing/2378/*.purs+                  , examples/failing/2379/*.purs                   , examples/failing/ConflictingExports/*.purs                   , examples/failing/ConflictingImports/*.purs                   , examples/failing/ConflictingImports2/*.purs@@ -119,9 +121,10 @@                    fsnotify >= 0.2.1,                    Glob >= 0.7 && < 0.8,                    haskeline >= 0.7.0.0,-                   http-client >= 0.4.30 && <0.6,+                   http-client >= 0.4.30 && <0.5,                    http-types -any,                    language-javascript == 0.6.*,+                   lens == 4.*,                    lifted-base >= 0.2.3 && < 0.2.4,                    monad-control >= 1.0.0.0 && < 1.1,                    monad-logger >= 0.3 && < 0.4,@@ -237,6 +240,7 @@                      Language.PureScript.TypeChecker.Subsumption                      Language.PureScript.TypeChecker.Synonyms                      Language.PureScript.TypeChecker.Types+                     Language.PureScript.TypeChecker.TypeSearch                      Language.PureScript.TypeChecker.Unify                      Language.PureScript.TypeClassDictionaries                      Language.PureScript.Types@@ -330,6 +334,7 @@                    mtl -any,                    optparse-applicative >= 0.12.1,                    parsec -any,+                   text -any,                    time -any,                    transformers -any,                    transformers-compat -any,@@ -383,6 +388,7 @@                    optparse-applicative >= 0.12.1,                    process -any,                    split -any,+                   text -any,                    transformers -any,                    transformers-compat -any     main-is: Main.hs@@ -406,6 +412,24 @@     hs-source-dirs: psc-publish     ghc-options: -Wall -O2 +executable psc-package+    build-depends: base >=4 && <5,+                   purescript -any,+                   aeson -any,+                   aeson-pretty -any,+                   bytestring -any,+                   containers -any,+                   foldl -any,+                   optparse-applicative -any,+                   system-filepath -any,+                   text -any,+                   turtle -any+    main-is: Main.hs+    other-modules: Paths_purescript+    buildable: True+    hs-source-dirs: psc-package+    ghc-options: -Wall -O2+ executable psc-hierarchy     build-depends: base >=4 && <5,                    purescript -any,@@ -415,7 +439,8 @@                    mtl -any,                    optparse-applicative >= 0.12.1,                    parsec -any,-                   process -any+                   process -any,+                   text -any     main-is: Main.hs     other-modules: Paths_purescript     buildable: True
src/Control/Monad/Supply.hs view
@@ -7,6 +7,7 @@  import Prelude.Compat +import Control.Applicative import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Reader import Control.Monad.State@@ -15,7 +16,7 @@ import Data.Functor.Identity  newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a }-  deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r)+  deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r, Alternative, MonadPlus)  runSupplyT :: Integer -> SupplyT m a -> m (a, Integer) runSupplyT n = flip runStateT n . unSupplyT
src/Control/Monad/Supply/Class.hs view
@@ -1,6 +1,9 @@ -- | -- A class for monads supporting a supply of fresh names --++{-# LANGUAGE DefaultSignatures #-}+ module Control.Monad.Supply.Class where  import Prelude.Compat@@ -11,18 +14,21 @@  class Monad m => MonadSupply m where   fresh :: m Integer+  peek :: m Integer+  default fresh :: MonadTrans t => t m Integer+  fresh = lift fresh+  default peek :: MonadTrans t => t m Integer+  peek = lift peek  instance Monad m => MonadSupply (SupplyT m) where   fresh = SupplyT $ do     n <- get     put (n + 1)     return n--instance MonadSupply m => MonadSupply (StateT s m) where-  fresh = lift fresh+  peek = SupplyT get -instance (Monoid w, MonadSupply m) => MonadSupply (WriterT w m) where-  fresh = lift fresh+instance MonadSupply m => MonadSupply (StateT s m)+instance (Monoid w, MonadSupply m) => MonadSupply (WriterT w m)  freshName :: MonadSupply m => m String freshName = fmap (('$' :) . show) fresh
src/Language/PureScript/AST/Declarations.hs view
@@ -29,6 +29,15 @@ -- | A map of locally-bound names in scope. type Context = [(Ident, Type)] +-- | Holds the data necessary to do type directed search for typed holes+data TypeSearch+  = TSBefore Environment+  -- ^ An Environment captured for later consumption by type directed search+  | TSAfter [(Qualified Ident, Type)]+  -- ^ Results of applying type directed search to the previously captured+  -- Environment+  deriving Show+ -- | A type of error messages data SimpleErrorMessage   = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)@@ -74,6 +83,8 @@   | ConstrainedTypeUnified Type Type   | OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident]   | NoInstanceFound Constraint+  | AmbiguousTypeVariables Type Constraint+  | UnknownClass (Qualified (ProperName 'ClassName))   | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]   | CannotDerive (Qualified (ProperName 'ClassName)) [Type]   | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [Type]@@ -99,7 +110,7 @@   | ShadowedTypeVar String   | UnusedTypeVar String   | WildcardInferredType Type Context-  | HoleInferredType String Type Context+  | HoleInferredType String Type Context TypeSearch   | MissingTypeDeclaration Ident Type   | OverlappingPattern [[Binder]] Bool   | IncompleteExhaustivityCheck@@ -123,7 +134,7 @@   | DeprecatedRequirePath   | CannotGeneralizeRecursiveFunction Ident Type   | CannotDeriveNewtypeForData (ProperName 'TypeName)-  | NonWildcardNewtypeInstance (ProperName 'TypeName)+  | ExpectedWildcard (ProperName 'TypeName)   deriving (Show)  -- | Error message hints, providing more detailed information about failure.@@ -249,6 +260,31 @@   (PositionedDeclarationRef _ _ r) == r' = r == r'   r == (PositionedDeclarationRef _ _ r') = r == r'   _ == _ = False++-- enable sorting lists of explicitly imported refs when suggesting imports in linting, IDE, etc.+-- not an Ord because this implementation is not consistent with its Eq instance.+-- think of it as a notion of contextual, not inherent, ordering.+compDecRef :: DeclarationRef -> DeclarationRef -> Ordering+compDecRef (TypeRef name _) (TypeRef name' _) = compare name name'+compDecRef (TypeOpRef name) (TypeOpRef name') = compare name name'+compDecRef (ValueRef ident) (ValueRef ident') = compare ident ident'+compDecRef (ValueOpRef name) (ValueOpRef name') = compare name name'+compDecRef (TypeClassRef name) (TypeClassRef name') = compare name name'+compDecRef (TypeInstanceRef ident) (TypeInstanceRef ident') = compare ident ident'+compDecRef (ModuleRef name) (ModuleRef name') = compare name name'+compDecRef (ReExportRef name _) (ReExportRef name' _) = compare name name'+compDecRef (PositionedDeclarationRef _ _ ref) ref' = compDecRef ref ref'+compDecRef ref (PositionedDeclarationRef _ _ ref') = compDecRef ref ref'+compDecRef ref ref' = compare+  (orderOf ref) (orderOf ref')+    where+      orderOf :: DeclarationRef -> Int+      orderOf (TypeClassRef _) = 0+      orderOf (TypeOpRef _) = 1+      orderOf (TypeRef _ _) = 2+      orderOf (ValueRef _) = 3+      orderOf (ValueOpRef _) = 4+      orderOf _ = 5  getTypeRef :: DeclarationRef -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) getTypeRef (TypeRef name dctors) = Just (name, dctors)
src/Language/PureScript/AST/Traversals.hs view
@@ -474,7 +474,8 @@     in foldMap (f'' s') ds   f' s (ValueDeclaration name _ bs (Right val)) =     let s' = S.insert name s-    in foldMap (h'' s') bs <> g'' s' val+        s'' = S.union s' (S.fromList (concatMap binderNames bs))+    in foldMap (h'' s') bs <> g'' s'' val   f' s (ValueDeclaration name _ bs (Left gs)) =     let s' = S.insert name s         s'' = S.union s' (S.fromList (concatMap binderNames bs))@@ -551,7 +552,7 @@   j' s (DoNotationValue v) = (s, g'' s v)   j' s (DoNotationBind b v) =     let s' = S.union (S.fromList (binderNames b)) s-    in (s', h'' s b <> g'' s' v)+    in (s', h'' s b <> g'' s v)   j' s (DoNotationLet ds) =     let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))     in (s', foldMap (f'' s') ds)@@ -586,3 +587,15 @@   forValues (DeferredDictionary _ tys) = mconcat (map f tys)   forValues (TypedValue _ _ ty) = f ty   forValues _ = mempty++-- |+-- Map a function over type annotations appearing inside a value+--+overTypes :: (Type -> Type) -> Expr -> Expr+overTypes f = let (_, f', _) = everywhereOnValues id g id in f'+  where+  g :: Expr -> Expr+  g (TypedValue checkTy val t) = TypedValue checkTy val (f t)+  g (TypeClassDictionary c sco hints) = TypeClassDictionary (mapConstraintArgs (map f) c) sco hints+  g other = other+
src/Language/PureScript/CodeGen/JS.hs view
@@ -244,23 +244,23 @@     ret <- valueToJs val     return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (ds' ++ [JSReturn Nothing ret]))) []   valueToJs' (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =-    return $ JSVariableIntroduction Nothing ctor (Just $+    return $ JSVariableIntroduction Nothing (properToJs ctor) (Just $                 JSObjectLiteral Nothing [("create",                   JSFunction Nothing Nothing ["value"]                     (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))])   valueToJs' (Constructor _ _ (ProperName ctor) []) =-    return $ iife ctor [ JSFunction Nothing (Just ctor) [] (JSBlock Nothing [])-           , JSAssignment Nothing (JSAccessor Nothing "value" (JSVar Nothing ctor))-                (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing ctor) []) ]+    return $ iife (properToJs ctor) [ JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing [])+           , JSAssignment Nothing (JSAccessor Nothing "value" (JSVar Nothing (properToJs ctor)))+                (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) []) ]   valueToJs' (Constructor _ _ (ProperName ctor) fields) =     let constructor =           let body = [ JSAssignment Nothing (JSAccessor Nothing (identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]-          in JSFunction Nothing (Just ctor) (identToJs `map` fields) (JSBlock Nothing body)+          in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body)         createFn =-          let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing ctor) (var `map` fields)+          let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields)           in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields-    in return $ iife ctor [ constructor-                          , JSAssignment Nothing (JSAccessor Nothing "create" (JSVar Nothing ctor)) createFn+    in return $ iife (properToJs ctor) [ constructor+                          , JSAssignment Nothing (JSAccessor Nothing "create" (JSVar Nothing (properToJs ctor))) createFn                           ]    iife :: String -> [JS] -> JS
src/Language/PureScript/CodeGen/JS/Common.hs view
@@ -26,10 +26,13 @@ --  * Symbols are prefixed with '$' followed by a symbol name or their ordinal value. -- identToJs :: Ident -> String-identToJs (Ident name)+identToJs (Ident name) = properToJs name+identToJs (GenIdent _ _) = internalError "GenIdent in identToJs"++properToJs :: String -> String+properToJs name   | nameIsJsReserved name || nameIsJsBuiltIn name = "$$" ++ name   | otherwise = concatMap identCharToString name-identToJs (GenIdent _ _) = internalError "GenIdent in identToJs"  -- | -- Test if a string is a valid JS identifier without escaping.
src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs view
@@ -99,15 +99,6 @@   fnSubtract = (C.dataRing, C.sub)   intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0)) -inlineNonClassFunction :: (String, String) -> (JS -> JS -> JS) -> JS -> JS-inlineNonClassFunction (m, op) f = everywhereOnJS convert-  where-  convert :: JS -> JS-  convert (JSApp _ (JSApp _ op' [x]) [y]) | isOp op' = f x y-  convert other = other-  isOp (JSAccessor _ op' (JSVar _ m')) = m == m' && op == op'-  isOp _ = False- inlineCommonOperators :: JS -> JS inlineCommonOperators = applyAll $   [ binary semiringNumber opAdd Add@@ -159,17 +150,17 @@   , binary heytingAlgebraBoolean opDisj Or   , unary  heytingAlgebraBoolean opNot Not -  , binary' C.dataIntBits (C..|.) BitwiseOr-  , binary' C.dataIntBits (C..&.) BitwiseAnd-  , binary' C.dataIntBits (C..^.) BitwiseXor+  , binary' C.dataIntBits C.or BitwiseOr+  , binary' C.dataIntBits C.and BitwiseAnd+  , binary' C.dataIntBits C.xor BitwiseXor   , binary' C.dataIntBits C.shl ShiftLeft   , binary' C.dataIntBits C.shr ShiftRight   , binary' C.dataIntBits C.zshr ZeroFillShiftRight   , unary'  C.dataIntBits C.complement BitwiseNot -  , inlineNonClassFunction (C.dataFunction, C.apply) $ \f x -> JSApp Nothing f [x]-  , inlineNonClassFunction (C.dataFunction, C.applyFlipped) $ \x f -> JSApp Nothing f [x]-  , inlineNonClassFunction (C.dataArrayUnsafe, C.unsafeIndex) $ flip (JSIndexer Nothing)+  , inlineNonClassFunction (isModFn (C.dataFunction, C.apply)) $ \f x -> JSApp Nothing f [x]+  , inlineNonClassFunction (isModFn (C.dataFunction, C.applyFlipped)) $ \x f -> JSApp Nothing f [x]+  , inlineNonClassFunction (isModFnWithDict (C.dataArray, C.unsafeIndex)) $ flip (JSIndexer Nothing)   ] ++   [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]   where@@ -232,6 +223,21 @@     go 0 acc (JSApp ss runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp ss fn acc)     go m acc (JSApp _ lhs [arg]) = go (m - 1) (arg : acc) lhs     go _ _   _ = Nothing++  inlineNonClassFunction :: (JS -> Bool) -> (JS -> JS -> JS) -> JS -> JS+  inlineNonClassFunction p f = everywhereOnJS convert+    where+    convert :: JS -> JS+    convert (JSApp _ (JSApp _ op' [x]) [y]) | p op' = f x y+    convert other = other++  isModFn :: (String, String) -> JS -> Bool+  isModFn (m, op) (JSAccessor _ op' (JSVar _ m')) = m == m' && op == op'+  isModFn _ _ = False++  isModFnWithDict :: (String, String) -> JS -> Bool+  isModFnWithDict (m, op) (JSApp _ (JSAccessor _ op' (JSVar _ m')) [(JSVar _ _)]) = m == m' && op == op'+  isModFnWithDict _ _ = False  -- (f <<< g $ x) = f (g x) -- (f <<< g)     = \x -> f (g x)
src/Language/PureScript/Constants.hs view
@@ -118,14 +118,14 @@ unsafeIndex :: String unsafeIndex = "unsafeIndex" -(.|.) :: String-(.|.) = ".|."+or :: String+or = "or" -(.&.) :: String-(.&.) = ".&."+and :: String+and = "and" -(.^.) :: String-(.^.) = ".^."+xor :: String+xor = "xor"  (<<<) :: String (<<<) = "<<<"@@ -346,8 +346,8 @@ prelude :: String prelude = "Prelude" -dataArrayUnsafe :: String-dataArrayUnsafe = "Data_Array_Unsafe"+dataArray :: String+dataArray = "Data_Array"  eff :: String eff = "Control_Monad_Eff"
src/Language/PureScript/Docs/ParseAndBookmark.hs view
@@ -9,13 +9,12 @@ import Control.Monad.IO.Class (MonadIO(..))  import qualified Data.Map as M+import Data.Text (Text)  import Language.PureScript.Docs.Convert (collectBookmarks) import Language.PureScript.Docs.Types import qualified Language.PureScript as P--import System.IO.UTF8 (readUTF8File)-+import System.IO.UTF8 (readUTF8FileT) import Web.Bower.PackageMeta (PackageName)  -- |@@ -45,7 +44,7 @@  parseFiles ::   (MonadError P.MultipleErrors m) =>-  [(FileInfo, FilePath)]+  [(FileInfo, Text)]   -> m [(FileInfo, P.Module)] parseFiles =   throwLeft . P.parseModulesFromFiles fileInfoToString@@ -77,10 +76,10 @@ fileInfoToString (Local fn) = fn fileInfoToString (FromDep _ fn) = fn -parseFile :: FilePath -> IO (FilePath, String)-parseFile input' = (,) input' <$> readUTF8File input'+parseFile :: FilePath -> IO (FilePath, Text)+parseFile input' = (,) input' <$> readUTF8FileT input' -parseAs :: (MonadIO m) => (FilePath -> a) -> FilePath -> m (a, String)+parseAs :: (MonadIO m) => (FilePath -> a) -> FilePath -> m (a, Text) parseAs g = fmap (first g) . liftIO . parseFile  getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName
src/Language/PureScript/Environment.hs view
@@ -236,8 +236,8 @@  -- | -- The primitive types in the external javascript environment with their--- associated kinds. There is also a pseudo `Partial` type that corresponds to--- the class with the same name.+-- associated kinds. There are also pseudo `Fail` and `Partial` types+-- that correspond to the classes with the same names. -- primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) primTypes =@@ -257,8 +257,9 @@     ]  -- |--- The primitive class map. This just contains to `Partial` class, used as a--- kind of magic constraint for partial functions.+-- The primitive class map. This just contains the `Fail` and `Partial`+-- classes. `Partial` is used as a kind of magic constraint for partial+-- functions. `Fail` is used for user-defined type errors. -- primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primClasses =
src/Language/PureScript/Errors.hs view
@@ -40,6 +40,7 @@ import qualified Text.Parsec as P import qualified Text.Parsec.Error as PE import qualified Text.PrettyPrint.Boxes as Box+import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers import Text.Parsec.Error (Message(..))  newtype ErrorSuggestion = ErrorSuggestion String@@ -117,6 +118,8 @@   ConstrainedTypeUnified{} -> "ConstrainedTypeUnified"   OverlappingInstances{} -> "OverlappingInstances"   NoInstanceFound{} -> "NoInstanceFound"+  AmbiguousTypeVariables{} -> "AmbiguousTypeVariables"+  UnknownClass{} -> "UnknownClass"   PossiblyInfiniteInstance{} -> "PossiblyInfiniteInstance"   CannotDerive{} -> "CannotDerive"   InvalidNewtypeInstance{} -> "InvalidNewtypeInstance"@@ -166,7 +169,7 @@   DeprecatedRequirePath{} -> "DeprecatedRequirePath"   CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction"   CannotDeriveNewtypeForData{} -> "CannotDeriveNewtypeForData"-  NonWildcardNewtypeInstance{} -> "NonWildcardNewtypeInstance"+  ExpectedWildcard{} -> "ExpectedWildcard"  -- | -- A stack trace for an error@@ -259,6 +262,7 @@   gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t   gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t   gSimple (NoInstanceFound con) = NoInstanceFound <$> overConstraintArgs (traverse f) con+  gSimple (AmbiguousTypeVariables t con) = AmbiguousTypeVariables <$> (f t) <*> pure con   gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts   gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts   gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts@@ -266,7 +270,7 @@   gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k   gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts   gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx-  gSimple (HoleInferredType name ty ctx) = HoleInferredType name <$> f ty <*> traverse (sndM f) ctx+  gSimple (HoleInferredType name ty ctx env) = HoleInferredType name <$> f ty <*> traverse (sndM f) ctx  <*> gTypeSearch env   gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty   gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty   gSimple other = pure other@@ -280,6 +284,9 @@   gHint (ErrorSolvingConstraint con) = ErrorSolvingConstraint <$> overConstraintArgs (traverse f) con   gHint other = pure other +  gTypeSearch (TSBefore env) = pure (TSBefore env)+  gTypeSearch (TSAfter result) = TSAfter <$> traverse (traverse f) result+ wikiUri :: ErrorMessage -> String wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e @@ -287,19 +294,19 @@ -- WildcardInferredType - source span not small enough -- DuplicateSelectiveImport - would require 2 ranges to remove and 1 insert errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion-errorSuggestion err = case err of-  UnusedImport{} -> emptySuggestion-  DuplicateImport{} -> emptySuggestion-  UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual-  UnusedDctorImport mn _ qual refs -> suggest $ importSuggestion mn refs qual-  UnusedDctorExplicitImport mn _ _ qual refs -> suggest $ importSuggestion mn refs qual-  ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing-  ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)-  HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing-  MissingTypeDeclaration ident ty -> suggest $ showIdent ident ++ " :: " ++ prettyPrintType ty-  WildcardInferredType ty _ -> suggest $ prettyPrintType ty-  _ -> Nothing-+errorSuggestion err =+    case err of+      UnusedImport{} -> emptySuggestion+      DuplicateImport{} -> emptySuggestion+      UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual+      UnusedDctorImport mn _ qual refs -> suggest $ importSuggestion mn refs qual+      UnusedDctorExplicitImport mn _ _ qual refs -> suggest $ importSuggestion mn refs qual+      ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing+      ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)+      HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing+      MissingTypeDeclaration ident ty -> suggest $ showIdent ident ++ " :: " ++ prettyPrintSuggestedType ty+      WildcardInferredType ty _ -> suggest $ prettyPrintSuggestedType ty+      _ -> Nothing   where     emptySuggestion = Just $ ErrorSuggestion ""     suggest = Just . ErrorSuggestion@@ -595,6 +602,11 @@             , line "They may be disallowed completely in a future version of the compiler."             ]     renderSimpleErrorMessage OverlappingInstances{} = internalError "OverlappingInstances: empty instance list"+    renderSimpleErrorMessage (UnknownClass nm) =+      paras [ line "No type class instance was found for class"+            , markCodeBox $ indent $ line (showQualified runProperName nm)+            , line "because the class was not in scope. Perhaps it was not exported."+            ]     renderSimpleErrorMessage (NoInstanceFound (Constraint C.Fail [ ty ] _)) | Just box <- toTypelevelString ty =       paras [ line "A custom type error occurred while solving type class constraints:"             , indent box@@ -626,6 +638,11 @@         where         go TUnknown{} = True         go _ = False+    renderSimpleErrorMessage (AmbiguousTypeVariables t _) =+      paras [ line "The inferred type"+            , indent $ line $ markCode $ prettyPrintType t+            , line "has type variables which are not mentioned in the body of the type. Consider adding a type annotation."+            ]     renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =       paras [ line "Type class instance for"             , markCodeBox $ indent $ Box.hsep 1 Box.left@@ -733,10 +750,31 @@       paras $ [ line "Wildcard type definition has the inferred type "               , markCodeBox $ indent $ typeAsBox ty               ] ++ renderContext ctx-    renderSimpleErrorMessage (HoleInferredType name ty ctx) =-      paras $ [ line $ "Hole '" ++ markCode name ++ "' has the inferred type "-              , markCodeBox $ indent $ typeAsBox ty-              ] ++ renderContext ctx+    renderSimpleErrorMessage (HoleInferredType name ty ctx ts) =+      let+        maxTSResults = 15+        tsResult = case ts of+          (TSAfter idents) | not (null idents) ->+            let+              formatTS (names, types) =+                let+                  idBoxes = Box.text . showQualified runIdent <$> names+                  tyBoxes = (\t -> BoxHelpers.indented+                              (Box.text ":: " Box.<> typeAsBox t)) <$> types+                  longestId = maximum (map Box.cols idBoxes)+                in+                  Box.vcat Box.top $+                      zipWith (Box.<>)+                      (Box.alignHoriz Box.left longestId <$> idBoxes)+                      tyBoxes+            in [ line "You could substitute the hole with one of these values:"+               , markCodeBox (indent (formatTS (unzip (take maxTSResults idents))))+               ]+          _ -> []+      in+        paras $ [ line $ "Hole '" ++ markCode name ++ "' has the inferred type "+                , markCodeBox (indent (typeAsBox ty))+                ] ++ tsResult ++ renderContext ctx     renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =       paras [ line $ "No type declaration was provided for the top-level declaration of " ++ markCode (showIdent ident) ++ "."             , line "It is good practice to provide type declarations as a form of documentation."@@ -834,8 +872,8 @@       paras [ line $ "Cannot derive an instance of the " ++ markCode "Newtype" ++ " class for non-newtype " ++ markCode (runProperName tyName) ++ "."             ] -    renderSimpleErrorMessage (NonWildcardNewtypeInstance tyName) =-      paras [ line $ "A type wildcard (_) should be used for the inner type when deriving the " ++ markCode "Newtype" ++ " instance for " ++ markCode (runProperName tyName) ++ "."+    renderSimpleErrorMessage (ExpectedWildcard tyName) =+      paras [ line $ "Expected a type wildcard (_) when deriving an instance for " ++ markCode (runProperName tyName) ++ "."             ]      renderHint :: ErrorMessageHint -> Box.Box -> Box.Box
src/Language/PureScript/Ide/CaseSplit.hs view
@@ -12,7 +12,7 @@ -- Casesplitting and adding function clauses ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE OverloadedStrings #-}  module Language.PureScript.Ide.CaseSplit        ( WildcardAnnotations()@@ -23,10 +23,10 @@        , caseSplit        ) where -import           Protolude hiding (Constructor)+import           Protolude                     hiding (Constructor) -import qualified Data.Text                               as T-import qualified Language.PureScript                     as P+import qualified Data.Text                     as T+import qualified Language.PureScript           as P  import           Language.PureScript.Externs import           Language.PureScript.Ide.Error@@ -34,8 +34,8 @@ import           Language.PureScript.Ide.Types import           Language.PureScript.Ide.Util -import           Text.Parsec                             as Parsec-import qualified Text.PrettyPrint.Boxes                  as Box+import           Text.Parsec                   as Parsec+import qualified Text.PrettyPrint.Boxes        as Box  type Constructor = (P.ProperName 'P.ConstructorName, [P.Type])
src/Language/PureScript/Ide/Command.hs view
@@ -12,7 +12,8 @@ -- Datatypes for the commands psc-ide accepts ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE OverloadedStrings #-}+  module Language.PureScript.Ide.Command where
src/Language/PureScript/Ide/Conversions.hs view
@@ -14,16 +14,23 @@  module Language.PureScript.Ide.Conversions where -import           Protolude-import           Data.Text           (unwords, lines, strip)+import           Control.Lens.Iso+import           Data.Text           (lines, strip, unwords) import qualified Language.PureScript as P+import           Protolude  runProperNameT :: P.ProperName a -> Text runProperNameT = toS . P.runProperName +properNameT :: Iso' (P.ProperName a) Text+properNameT = iso (toS . P.runProperName) (P.ProperName . toS)+ runIdentT :: P.Ident -> Text runIdentT = toS . P.runIdent +identT :: Iso' P.Ident Text+identT = iso (toS . P.runIdent) (P.Ident . toS)+ runOpNameT :: P.OpName a -> Text runOpNameT = toS . P.runOpName @@ -32,4 +39,3 @@  prettyTypeT :: P.Type -> Text prettyTypeT = unwords . map strip . lines . toS . P.prettyPrintType-
src/Language/PureScript/Ide/Error.hs view
@@ -17,11 +17,11 @@        ( PscIdeError(..)        ) where -import           Protolude import           Data.Aeson import           Language.PureScript.Errors.JSON-import           Language.PureScript.Ide.Types (ModuleIdent)-import qualified Text.Parsec.Error             as P+import           Language.PureScript.Ide.Types   (ModuleIdent)+import           Protolude+import qualified Text.Parsec.Error               as P  data PscIdeError     = GeneralError Text
src/Language/PureScript/Ide/Externs.hs view
@@ -14,7 +14,6 @@  {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE FlexibleContexts  #-}  module Language.PureScript.Ide.Externs   ( readExternFile@@ -24,10 +23,11 @@  import           Protolude +import           Control.Lens                  ((^.)) import           Data.Aeson                    (decodeStrict)+import qualified Data.ByteString               as BS import           Data.List                     (nub) import qualified Data.Map                      as Map-import qualified Data.ByteString               as BS import           Language.PureScript.Ide.Error (PscIdeError (..)) import           Language.PureScript.Ide.Types import           Language.PureScript.Ide.Util@@ -58,14 +58,14 @@     cleanDeclarations = nub $ appEndo typeClassFilter declarations  removeTypeDeclarationsForClass :: IdeDeclaration -> Endo [IdeDeclaration]-removeTypeDeclarationsForClass (IdeTypeClass n) = Endo (filter notDuplicate)-  where notDuplicate (IdeType n' _) = runProperNameT n /= runProperNameT n'-        notDuplicate (IdeTypeSynonym n' _) = runProperNameT n /= runProperNameT n'+removeTypeDeclarationsForClass (IdeDeclTypeClass n) = Endo (filter notDuplicate)+  where notDuplicate (IdeDeclType t) = n ^. properNameT /= t ^. ideTypeName . properNameT+        notDuplicate (IdeDeclTypeSynonym s) = n ^. properNameT /= s ^. ideSynonymName . properNameT         notDuplicate _ = True removeTypeDeclarationsForClass _ = mempty  isTypeClassDeclaration :: IdeDeclaration -> Bool-isTypeClassDeclaration IdeTypeClass{} = True+isTypeClassDeclaration IdeDeclTypeClass{} = True isTypeClassDeclaration _ = False  convertExport :: P.DeclarationRef -> Maybe (P.ModuleName, P.DeclarationRef)@@ -73,19 +73,20 @@ convertExport _ = Nothing  convertDecl :: P.ExternsDeclaration -> Maybe IdeDeclaration-convertDecl P.EDType{..} = Just (IdeType edTypeName edTypeKind)-convertDecl P.EDTypeSynonym{..} =-  Just (IdeTypeSynonym edTypeSynonymName edTypeSynonymType)-convertDecl P.EDDataConstructor{..} = Just $+convertDecl P.EDType{..} = Just $ IdeDeclType $+  IdeType edTypeName edTypeKind+convertDecl P.EDTypeSynonym{..} = Just $ IdeDeclTypeSynonym+  (IdeSynonym edTypeSynonymName edTypeSynonymType)+convertDecl P.EDDataConstructor{..} = Just $ IdeDeclDataConstructor $   IdeDataConstructor edDataCtorName edDataCtorTypeCtor edDataCtorType-convertDecl P.EDValue{..} = Just $+convertDecl P.EDValue{..} = Just $ IdeDeclValue $   IdeValue edValueName edValueType-convertDecl P.EDClass{..} = Just (IdeTypeClass edClassName)+convertDecl P.EDClass{..} = Just (IdeDeclTypeClass edClassName) convertDecl P.EDInstance{} = Nothing  convertOperator :: P.ExternsFixity -> IdeDeclaration convertOperator P.ExternsFixity{..} =-  IdeValueOperator+  IdeDeclValueOperator $ IdeValueOperator     efOperator     efAlias     efPrecedence@@ -94,7 +95,7 @@  convertTypeOperator :: P.ExternsTypeFixity -> IdeDeclaration convertTypeOperator P.ExternsTypeFixity{..} =-  IdeTypeOperator+  IdeDeclTypeOperator $ IdeTypeOperator     efTypeOperator     efTypeAlias     efTypePrecedence@@ -110,20 +111,20 @@   where     convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn     convertDeclaration (IdeDeclarationAnn ann d) = case d of-      IdeValue i t ->-        annotateFunction i (IdeValue i t)-      IdeType i k ->-        annotateType (runProperNameT i) (IdeType i k)-      IdeTypeSynonym i t ->-        annotateType (runProperNameT i) (IdeTypeSynonym i t)-      IdeDataConstructor i tn t ->-        annotateValue (runProperNameT i) (IdeDataConstructor i tn t)-      IdeTypeClass i ->-        annotateType (runProperNameT i) (IdeTypeClass i)-      IdeValueOperator n i p a t ->-        annotateValue (valueOperatorAliasT i) (IdeValueOperator n i p a t)-      IdeTypeOperator n i p a k ->-        annotateType (typeOperatorAliasT i) (IdeTypeOperator n i p a k)+      IdeDeclValue v ->+        annotateFunction (v ^. ideValueIdent) (IdeDeclValue v)+      IdeDeclType t ->+        annotateType (t ^. ideTypeName . properNameT) (IdeDeclType t)+      IdeDeclTypeSynonym s ->+        annotateType (s ^. ideSynonymName . properNameT) (IdeDeclTypeSynonym s)+      IdeDeclDataConstructor dtor ->+        annotateValue (dtor ^. ideDtorName . properNameT) (IdeDeclDataConstructor dtor)+      IdeDeclTypeClass i ->+        annotateType (runProperNameT i) (IdeDeclTypeClass i)+      IdeDeclValueOperator op ->+        annotateValue (op ^. ideValueOpAlias & valueOperatorAliasT) (IdeDeclValueOperator op)+      IdeDeclTypeOperator op ->+        annotateType (op ^. ideTypeOpAlias & typeOperatorAliasT) (IdeDeclTypeOperator op)       where         annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (Left (runIdentT x)) defs                                                     , annTypeAnnotation = Map.lookup x types
src/Language/PureScript/Ide/Filter.hs view
@@ -23,13 +23,13 @@        , applyFilters        ) where -import           Protolude hiding (isPrefixOf)+import           Protolude                     hiding (isPrefixOf)  import           Data.Aeson import           Data.Text                     (isPrefixOf)+import qualified Language.PureScript           as P import           Language.PureScript.Ide.Types import           Language.PureScript.Ide.Util-import qualified Language.PureScript as P  newtype Filter = Filter (Endo [Module]) deriving(Monoid) @@ -65,8 +65,7 @@   where     filterModuleDecls :: Module -> Module     filterModuleDecls (moduleIdent, decls) =-        (moduleIdent, filter (flip predicate search . getDeclaration) decls)-    getDeclaration (IdeDeclarationAnn _ d) = d+        (moduleIdent, filter (flip predicate search . discardAnn) decls)  runFilter :: Filter -> [Module] -> [Module] runFilter (Filter f) = appEndo f
src/Language/PureScript/Ide/Imports.hs view
@@ -30,9 +30,10 @@        where  import           Protolude++import           Control.Lens                       ((^.))+import           Data.List                          (findIndex, nubBy) import qualified Data.Text                          as T-import           Data.List                          (nubBy, findIndex)-import qualified Data.Text.IO                       as TIO import qualified Language.PureScript                as P import           Language.PureScript.Ide.Completion import           Language.PureScript.Ide.Error@@ -40,6 +41,7 @@ import           Language.PureScript.Ide.State import           Language.PureScript.Ide.Types import           Language.PureScript.Ide.Util+import           System.IO.UTF8                     (readUTF8FileT, writeUTF8FileT)  data Import = Import P.ModuleName P.ImportDeclarationType  (Maybe P.ModuleName)               deriving (Eq, Show)@@ -70,7 +72,7 @@ parseImportsFromFile :: (MonadIO m, MonadError PscIdeError m) =>                         FilePath -> m (P.ModuleName, [Text], [Import], [Text]) parseImportsFromFile fp = do-  file <- liftIO (TIO.readFile fp)+  file <- liftIO (readUTF8FileT fp)   case sliceImportSection (T.lines file) of     Right res -> pure res     Left err -> throwError (GeneralError err)@@ -197,16 +199,16 @@     then imports     else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports   where-    refFromDeclaration (IdeTypeClass n) =+    refFromDeclaration (IdeDeclTypeClass n) =       P.TypeClassRef n-    refFromDeclaration (IdeDataConstructor n tn _) =-      P.TypeRef tn (Just [n])-    refFromDeclaration (IdeType n _) =-      P.TypeRef n (Just [])-    refFromDeclaration (IdeValueOperator op _ _ _ _) =-      P.ValueOpRef op-    refFromDeclaration (IdeTypeOperator op _ _ _ _) =-      P.TypeOpRef op+    refFromDeclaration (IdeDeclDataConstructor dtor) =+      P.TypeRef (dtor ^. ideDtorTypeName) Nothing+    refFromDeclaration (IdeDeclType t) =+      P.TypeRef (t ^. ideTypeName) (Just [])+    refFromDeclaration (IdeDeclValueOperator op) =+      P.ValueOpRef (op ^. ideValueOpName)+    refFromDeclaration (IdeDeclTypeOperator op) =+      P.TypeOpRef (op ^. ideTypeOpName)     refFromDeclaration d =       P.ValueRef $ P.Ident $ T.unpack (identifierFromIdeDeclaration d) @@ -214,20 +216,19 @@     -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe)     insertDeclIntoImport :: IdeDeclaration -> Import -> Import     insertDeclIntoImport decl' (Import mn (P.Explicit refs) Nothing) =-      Import mn (P.Explicit (insertDeclIntoRefs decl' refs)) Nothing+      Import mn (P.Explicit (sortBy P.compDecRef (insertDeclIntoRefs decl' refs))) Nothing     insertDeclIntoImport _ is = is      insertDeclIntoRefs :: IdeDeclaration -> [P.DeclarationRef] -> [P.DeclarationRef]-    insertDeclIntoRefs (IdeDataConstructor dtor tn _) refs =-      updateAtFirstOrPrepend (matchType tn) (insertDtor dtor) (P.TypeRef tn (Just [dtor])) refs+    insertDeclIntoRefs d@(IdeDeclDataConstructor dtor) refs =+      updateAtFirstOrPrepend+        (matchType (dtor ^. ideDtorTypeName))+        (insertDtor (dtor ^. ideDtorName))+        (refFromDeclaration d)+        refs     insertDeclIntoRefs dr refs = nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs) -    insertDtor dtor (P.TypeRef tn' dtors) =-      case dtors of-        Just dtors' -> P.TypeRef tn' (Just (ordNub (dtor : dtors')))-        -- This means the import was opened. We don't add anything in this case-        -- import Data.Maybe (Maybe(..)) -> import Data.Maybe (Maybe(Just))-        Nothing -> P.TypeRef tn' Nothing+    insertDtor _ (P.TypeRef tn' _) = P.TypeRef tn' Nothing     insertDtor _ refs = refs      matchType :: P.ProperName 'P.TypeName -> P.DeclarationRef -> Bool@@ -294,9 +295,9 @@     xs ->       pure $ Left xs     where-      decideRedundantCase dtor@(IdeDataConstructor _ t _) (IdeType t' _) =-        if t == t' then Just dtor else Nothing-      decideRedundantCase IdeType{} ts@IdeTypeSynonym{} =+      decideRedundantCase d@(IdeDeclDataConstructor dtor) (IdeDeclType t) =+        if dtor ^. ideDtorTypeName == t ^. ideTypeName then Just d else Nothing+      decideRedundantCase IdeDeclType{} ts@IdeDeclTypeSynonym{} =         Just ts       decideRedundantCase _ _ = Nothing @@ -316,10 +317,10 @@ answerRequest :: (MonadIO m) => Maybe FilePath -> [Text] -> m Success answerRequest outfp rs  =   case outfp of-    Nothing -> pure $ MultilineTextResult rs+    Nothing -> pure (MultilineTextResult rs)     Just outfp' -> do-      liftIO $ TIO.writeFile outfp' (T.unlines rs)-      pure $ TextResult $ "Written to " <> T.pack outfp'+      liftIO (writeUTF8FileT outfp' (T.unlines rs))+      pure (TextResult ("Written to " <> T.pack outfp'))  -- | Test and ghci helper parseImport :: Text -> Maybe Import
src/Language/PureScript/Ide/Matcher.hs view
@@ -12,9 +12,9 @@ -- Matchers for psc-ide commands ----------------------------------------------------------------------------- +{-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE FlexibleInstances          #-}  module Language.PureScript.Ide.Matcher        ( Matcher
src/Language/PureScript/Ide/Pursuit.hs view
@@ -12,7 +12,7 @@ -- Pursuit client for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE OverloadedStrings #-}  module Language.PureScript.Ide.Pursuit   ( searchPursuitForDeclarations@@ -35,37 +35,41 @@ -- TODO: remove this when the issue is fixed at Pursuit queryPursuit :: Text -> IO ByteString queryPursuit q = do-    let qClean = T.dropWhileEnd (== '.') q-    req' <- parseRequest "http://pursuit.purescript.org/search"-    let req = req'-          { queryString= "q=" <> (fromString . T.unpack) qClean-          , requestHeaders=[(hAccept, "application/json")]-          }-    m <- newManager tlsManagerSettings-    withHTTP req m $ \resp ->-      P.fold (<>) "" identity (responseBody resp)+  let qClean = T.dropWhileEnd (== '.') q+  req' <- parseRequest "http://pursuit.purescript.org/search"+  let req = req'+        { queryString= "q=" <> (fromString . T.unpack) qClean+        , requestHeaders=[(hAccept, "application/json")]+        }+  m <- newManager tlsManagerSettings+  withHTTP req m $ \resp ->+    P.fold (<>) "" identity (responseBody resp) + handler :: HttpException -> IO [a]+handler StatusCodeException{} = pure [] handler _ = pure []  searchPursuitForDeclarations :: Text -> IO [PursuitResponse]-searchPursuitForDeclarations query = E.handle handler $ do-    r <- queryPursuit query-    let results' = decode (fromStrict r) :: Maybe Array-    case results' of-        Nothing -> pure []-        Just results -> pure (mapMaybe (isDeclarationResponse . fromJSON) (toList results))+searchPursuitForDeclarations query =+    (do r <- queryPursuit query+        let results' = decode (fromStrict r) :: Maybe Array+        case results' of+          Nothing -> pure []+          Just results -> pure (mapMaybe (isDeclarationResponse . fromJSON) (toList results))) `E.catch`+    handler   where     isDeclarationResponse (Success a@DeclarationResponse{}) = Just a     isDeclarationResponse _ = Nothing  findPackagesForModuleIdent :: Text -> IO [PursuitResponse]-findPackagesForModuleIdent query = E.handle handler $ do-    r <- queryPursuit query-    let results' = decode (fromStrict r) :: Maybe Array-    case results' of+findPackagesForModuleIdent query =+  (do r <- queryPursuit query+      let results' = decode (fromStrict r) :: Maybe Array+      case results' of         Nothing -> pure []-        Just results -> pure (mapMaybe (isModuleResponse . fromJSON) (toList results))+        Just results -> pure (mapMaybe (isModuleResponse . fromJSON) (toList results))) `E.catch`+  handler   where     isModuleResponse (Success a@ModuleResponse{}) = Just a     isModuleResponse _ = Nothing
src/Language/PureScript/Ide/Rebuild.hs view
@@ -11,7 +11,7 @@ import           Protolude  import           "monad-logger" Control.Monad.Logger-import qualified Data.List as List+import qualified Data.List                       as List import qualified Data.Map.Lazy                   as M import           Data.Maybe                      (fromJust) import qualified Data.Set                        as S@@ -21,7 +21,7 @@ import           Language.PureScript.Ide.State import           Language.PureScript.Ide.Types import           Language.PureScript.Ide.Util-import           System.IO.UTF8                  (readUTF8File)+import           System.IO.UTF8                  (readUTF8FileT)  -- | Given a filepath performs the following steps: --@@ -44,7 +44,7 @@   -> m Success rebuildFile path = do -  input <- liftIO (readUTF8File path)+  input <- liftIO (readUTF8FileT path)    m <- case snd <$> P.parseModuleFromFile identity (path, input) of     Left parseError -> throwError
src/Language/PureScript/Ide/Reexports.hs view
@@ -25,16 +25,18 @@  import           Protolude +import           Control.Lens                  hiding ((&))+ import qualified Data.Map                      as Map+import qualified Language.PureScript           as P import           Language.PureScript.Ide.Types import           Language.PureScript.Ide.Util-import qualified Language.PureScript as P  -- | Contains the module with resolved reexports, and eventual failures data ReexportResult a   = ReexportResult   { reResolved :: a-  , reFailed :: [(P.ModuleName, P.DeclarationRef)]+  , reFailed   :: [(P.ModuleName, P.DeclarationRef)]   } deriving (Show, Eq, Functor)  -- | Uses the passed formatter to format the resolved module, and adds eventual@@ -79,7 +81,7 @@   -> Either P.DeclarationRef [IdeDeclarationAnn] resolveRef decls ref = case ref of   P.TypeRef tn mdtors ->-    case findRef (\case IdeType name _ -> name == tn; _ -> False) of+    case findRef (\x -> x ^? _IdeDeclType . ideTypeName <&> (== tn) & fromMaybe False) of       Nothing -> Left ref       Just d -> Right $ d : case mdtors of           Nothing ->@@ -89,28 +91,23 @@             findDtors tn           Just dtors -> mapMaybe lookupDtor dtors   P.ValueRef i ->-    findWrapped (\case IdeValue i' _ -> i' == i; _ -> False)-  P.TypeOpRef name ->-    findWrapped (\case IdeTypeOperator n _ _ _ _ -> n == name; _ -> False)+    findWrapped (\x -> x ^? _IdeDeclValue . ideValueIdent <&> (== i) & fromMaybe False)   P.ValueOpRef name ->-    findWrapped (\case IdeValueOperator n _ _ _ _ -> n == name; _ -> False)+    findWrapped (\x -> x ^? _IdeDeclValueOperator . ideValueOpName <&> (== name) & fromMaybe False)+  P.TypeOpRef name ->+    findWrapped (\x -> x ^? _IdeDeclTypeOperator . ideTypeOpName <&> (== name) & fromMaybe False)   P.TypeClassRef name ->-    findWrapped (\case IdeTypeClass n -> n == name; _ -> False)+    findWrapped (\case IdeDeclTypeClass n -> n == name; _ -> False)   _ ->     Left ref   where-    findWrapped = wrapSingle . findRef-    wrapSingle = maybe (Left ref) (Right . pure)+    findWrapped = maybe (Left ref) (Right . pure) . findRef     findRef f = find (f . discardAnn) decls      lookupDtor name =-      findRef (\case IdeDataConstructor name' _ _ -> name == name'-                     _ -> False)+      findRef (\x -> x ^? _IdeDeclDataConstructor . ideDtorName <&> (== name) & fromMaybe False)      findDtors tn = filter (f . discardAnn) decls       where         f :: IdeDeclaration -> Bool-        f decl-          | (IdeDataConstructor _ tn' _) <- decl-          , tn == tn' = True-          | otherwise = False+        f decl = decl ^? _IdeDeclDataConstructor . ideDtorTypeName <&> (== tn) & fromMaybe False
src/Language/PureScript/Ide/SourceFile.hs view
@@ -12,7 +12,7 @@ -- Getting declarations from PureScript sourcefiles ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE OverloadedStrings #-}  module Language.PureScript.Ide.SourceFile   ( parseModule@@ -25,19 +25,19 @@  import           Protolude -import qualified Data.Map as Map-import qualified Language.PureScript                  as P+import qualified Data.Map                      as Map+import qualified Language.PureScript           as P import           Language.PureScript.Ide.Error-import           Language.PureScript.Ide.Util import           Language.PureScript.Ide.Types-import           System.IO.UTF8                       (readUTF8File)+import           Language.PureScript.Ide.Util+import           System.IO.UTF8                (readUTF8FileT)  parseModule   :: (MonadIO m)   => FilePath-  -> m (Either FilePath (FilePath, P.Module) )+  -> m (Either FilePath (FilePath, P.Module)) parseModule path = do-  contents <- liftIO (readUTF8File path)+  contents <- liftIO (readUTF8FileT path)   case P.parseModuleFromFile identity (path, contents) of     Left _ -> pure (Left path)     Right m -> pure (Right m)
src/Language/PureScript/Ide/State.hs view
@@ -32,20 +32,20 @@   , resolveOperatorsForModule   ) where -import           Protolude import qualified Prelude+import           Protolude  import           Control.Concurrent.STM+import           Control.Lens                       hiding (op, (&)) import           "monad-logger" Control.Monad.Logger-import qualified Data.Map.Lazy                     as Map-import qualified Data.List                         as List+import qualified Data.Map.Lazy                      as Map+import qualified Language.PureScript                as P import           Language.PureScript.Externs import           Language.PureScript.Ide.Externs import           Language.PureScript.Ide.Reexports import           Language.PureScript.Ide.SourceFile import           Language.PureScript.Ide.Types import           Language.PureScript.Ide.Util-import qualified Language.PureScript as P import           System.Clock  -- | Resets all State inside psc-ide@@ -235,47 +235,39 @@   :: Map P.ModuleName [IdeDeclarationAnn]   -> [IdeDeclarationAnn]   -> [IdeDeclarationAnn]-resolveOperatorsForModule modules = map (mapIdeDeclaration resolveOperator)+resolveOperatorsForModule modules = map ((over idaDeclaration) resolveOperator)   where-    resolveOperator (IdeValueOperator-                    opName-                    i@(P.Qualified (Just moduleName)-                        (Left ident)) precedence assoc _) =-      let t = do-            sourceModule <- Map.lookup moduleName modules-            IdeValue _ tP <--              List.find (\case-                            IdeValue iP _ -> iP == ident-                            _ -> False) (discardAnn <$> sourceModule)-            pure tP--      in IdeValueOperator opName i precedence assoc t-    resolveOperator (IdeValueOperator-                    opName-                    i@(P.Qualified (Just moduleName)-                        (Right ctor)) precedence assoc _) =-      let t = do-            sourceModule <- Map.lookup moduleName modules-            IdeDataConstructor _ _ tP <--              List.find (\case-                            IdeDataConstructor cname _ _ -> ctor == cname-                            _ -> False) (discardAnn <$> sourceModule)-            pure tP+    hasName :: Eq b => Lens' a b -> b -> a -> Bool+    hasName l a x = x ^. l == a -      in IdeValueOperator opName i precedence assoc t-    resolveOperator (IdeTypeOperator-                    opName-                    i@(P.Qualified (Just moduleName) properName) precedence assoc _)  =-      let k = do-            sourceModule <- Map.lookup moduleName modules-            IdeType _ kP <--              List.find (\case-                            IdeType name _ -> name == properName-                            _ -> False) (discardAnn <$> sourceModule)-            pure kP+    getDeclarations :: P.ModuleName -> [IdeDeclaration]+    getDeclarations moduleName =+      Map.lookup moduleName modules+      & fromMaybe []+      & map discardAnn -      in IdeTypeOperator opName i precedence assoc k+    resolveOperator (IdeDeclValueOperator op)+      | (P.Qualified (Just mn) (Left ident)) <- op ^. ideValueOpAlias =+          let t = getDeclarations mn+                  & mapMaybe (preview _IdeDeclValue)+                  & filter (hasName ideValueIdent ident)+                  & map (view ideValueType)+                  & listToMaybe+          in IdeDeclValueOperator (op & ideValueOpType .~ t)+      | (P.Qualified (Just mn) (Right dtor)) <- op ^. ideValueOpAlias =+          let t = getDeclarations mn+                  & mapMaybe (preview _IdeDeclDataConstructor)+                  & filter (hasName ideDtorName dtor)+                  & map (view ideDtorType)+                  & listToMaybe+          in IdeDeclValueOperator (op & ideValueOpType .~ t)+    resolveOperator (IdeDeclTypeOperator op)+      | P.Qualified (Just mn) properName <- op ^. ideTypeOpAlias =+          let k = getDeclarations mn+                  & mapMaybe (preview _IdeDeclType)+                  & filter (hasName ideTypeName properName)+                  & map (view ideTypeKind)+                  & listToMaybe+          in IdeDeclTypeOperator (op & ideTypeOpKind .~ k)     resolveOperator x = x -mapIdeDeclaration :: (IdeDeclaration -> IdeDeclaration) -> IdeDeclarationAnn -> IdeDeclarationAnn-mapIdeDeclaration f (IdeDeclarationAnn ann decl) = IdeDeclarationAnn ann (f decl)
src/Language/PureScript/Ide/Types.hs view
@@ -12,42 +12,93 @@ -- Type definitions for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveFoldable    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}  module Language.PureScript.Ide.Types where  import           Protolude  import           Control.Concurrent.STM+import           Control.Lens.TH import           Data.Aeson-import qualified Data.Map.Lazy                        as M-import qualified Language.PureScript.Errors.JSON      as P-import qualified Language.PureScript as P+import qualified Data.Map.Lazy                       as M+import qualified Language.PureScript                 as P+import qualified Language.PureScript.Errors.JSON     as P import           Language.PureScript.Ide.Conversions  type ModuleIdent = Text  data IdeDeclaration-  = IdeValue P.Ident P.Type-  | IdeType (P.ProperName 'P.TypeName) P.Kind-  | IdeTypeSynonym (P.ProperName 'P.TypeName) P.Type-  | IdeDataConstructor (P.ProperName 'P.ConstructorName) (P.ProperName 'P.TypeName) P.Type-  | IdeTypeClass (P.ProperName 'P.ClassName)-  | IdeValueOperator (P.OpName 'P.ValueOpName) (P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName))) P.Precedence P.Associativity (Maybe P.Type)-  | IdeTypeOperator (P.OpName 'P.TypeOpName) (P.Qualified (P.ProperName 'P.TypeName)) P.Precedence P.Associativity (Maybe P.Kind)+  = IdeDeclValue IdeValue+  | IdeDeclType IdeType+  | IdeDeclTypeSynonym IdeSynonym+  | IdeDeclDataConstructor IdeDataConstructor+  | IdeDeclTypeClass (P.ProperName 'P.ClassName)+  | IdeDeclValueOperator IdeValueOperator+  | IdeDeclTypeOperator IdeTypeOperator   deriving (Show, Eq, Ord) -data IdeDeclarationAnn = IdeDeclarationAnn Annotation IdeDeclaration-  deriving (Show, Eq, Ord)+data IdeValue = IdeValue+  { _ideValueIdent :: P.Ident+  , _ideValueType  :: P.Type+  } deriving (Show, Eq, Ord) +data IdeType = IdeType+ { _ideTypeName :: P.ProperName 'P.TypeName+ , _ideTypeKind :: P.Kind+ } deriving (Show, Eq, Ord)++data IdeSynonym = IdeSynonym+  { _ideSynonymName :: P.ProperName 'P.TypeName+  , _ideSynonymType :: P.Type+  } deriving (Show, Eq, Ord)++data IdeDataConstructor = IdeDataConstructor+  { _ideDtorName     :: P.ProperName 'P.ConstructorName+  , _ideDtorTypeName :: P.ProperName 'P.TypeName+  , _ideDtorType     :: P.Type+  } deriving (Show, Eq, Ord)++data IdeValueOperator = IdeValueOperator+  { _ideValueOpName          :: P.OpName 'P.ValueOpName+  , _ideValueOpAlias         :: P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName))+  , _ideValueOpPrecedence    :: P.Precedence+  , _ideValueOpAssociativity :: P.Associativity+  , _ideValueOpType          :: Maybe P.Type+  } deriving (Show, Eq, Ord)++data IdeTypeOperator = IdeTypeOperator+  { _ideTypeOpName          :: P.OpName 'P.TypeOpName+  , _ideTypeOpAlias         :: P.Qualified (P.ProperName 'P.TypeName)+  , _ideTypeOpPrecedence    :: P.Precedence+  , _ideTypeOpAssociativity :: P.Associativity+  , _ideTypeOpKind          :: Maybe P.Kind+  } deriving (Show, Eq, Ord)++makePrisms ''IdeDeclaration+makeLenses ''IdeValue+makeLenses ''IdeType+makeLenses ''IdeSynonym+makeLenses ''IdeDataConstructor+makeLenses ''IdeValueOperator+makeLenses ''IdeTypeOperator++data IdeDeclarationAnn = IdeDeclarationAnn+  { _idaAnnotation  :: Annotation+  , _idaDeclaration :: IdeDeclaration+  } deriving (Show, Eq, Ord)+ data Annotation   = Annotation-  { annLocation     :: Maybe P.SourceSpan-  , annExportedFrom :: Maybe P.ModuleName+  { annLocation       :: Maybe P.SourceSpan+  , annExportedFrom   :: Maybe P.ModuleName   , annTypeAnnotation :: Maybe P.Type   } deriving (Show, Eq, Ord) +makeLenses ''IdeDeclarationAnn+ emptyAnn :: Annotation emptyAnn = Annotation Nothing Nothing Nothing @@ -103,7 +154,7 @@   }  data Stage3 = Stage3-  { s3Declarations :: M.Map P.ModuleName [IdeDeclarationAnn]+  { s3Declarations  :: M.Map P.ModuleName [IdeDeclarationAnn]   , s3CachedRebuild :: Maybe (P.ModuleName, P.ExternsFile)   } @@ -112,11 +163,11 @@  -- | A completion as it gets sent to the editors data Completion = Completion-  { complModule :: Text-  , complIdentifier :: Text-  , complType :: Text-  , complExpandedType :: Text-  , complLocation :: Maybe P.SourceSpan+  { complModule        :: Text+  , complIdentifier    :: Text+  , complType          :: Text+  , complExpandedType  :: Text+  , complLocation      :: Maybe P.SourceSpan   , complDocumentation :: Maybe Text   } deriving (Show, Eq)
src/Language/PureScript/Ide/Util.hs view
@@ -29,23 +29,25 @@   , module Language.PureScript.Ide.Conversions   ) where -import           Protolude                     hiding (decodeUtf8, encodeUtf8)+import           Control.Lens                        ((^.)) import           Data.Aeson-import qualified Data.Text                     as T-import           Data.Text.Lazy.Encoding       (decodeUtf8, encodeUtf8)-import qualified Language.PureScript           as P-import           Language.PureScript.Ide.Types+import qualified Data.Text                           as T+import           Data.Text.Lazy.Encoding             (decodeUtf8, encodeUtf8)+import qualified Language.PureScript                 as P import           Language.PureScript.Ide.Conversions+import           Language.PureScript.Ide.Types+import           Protolude                           hiding (decodeUtf8,+                                                      encodeUtf8)  identifierFromIdeDeclaration :: IdeDeclaration -> Text identifierFromIdeDeclaration d = case d of-  IdeValue name _ -> runIdentT name-  IdeType name _ -> runProperNameT name-  IdeTypeSynonym name _ -> runProperNameT name-  IdeDataConstructor name _ _ -> runProperNameT name-  IdeTypeClass name -> runProperNameT name-  IdeValueOperator op _ _ _ _ -> runOpNameT op-  IdeTypeOperator op _ _ _ _ -> runOpNameT op+  IdeDeclValue v -> v ^. ideValueIdent . identT+  IdeDeclType t -> t ^. ideTypeName . properNameT+  IdeDeclTypeSynonym s -> s ^. ideSynonymName . properNameT+  IdeDeclDataConstructor dtor -> dtor ^. ideDtorName . properNameT+  IdeDeclTypeClass name -> runProperNameT name+  IdeDeclValueOperator op -> op ^. ideValueOpName & runOpNameT+  IdeDeclTypeOperator op -> op ^. ideTypeOpName & runOpNameT  discardAnn :: IdeDeclarationAnn -> IdeDeclaration discardAnn (IdeDeclarationAnn _ d) = d@@ -61,24 +63,24 @@   Completion {..}   where     (complIdentifier, complExpandedType) = case decl of-      IdeValue name type' -> (runIdentT name, prettyTypeT type')-      IdeType name kind -> (runProperNameT name, toS (P.prettyPrintKind kind))-      IdeTypeSynonym name kind -> (runProperNameT name, prettyTypeT kind)-      IdeDataConstructor name _ type' -> (runProperNameT name, prettyTypeT type')-      IdeTypeClass name -> (runProperNameT name, "class")-      IdeValueOperator op ref precedence associativity typeP ->-        (runOpNameT op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP) -      IdeTypeOperator op ref precedence associativity kind ->+      IdeDeclValue v -> (v ^. ideValueIdent . identT, v ^. ideValueType & prettyTypeT)+      IdeDeclType t -> (t ^. ideTypeName . properNameT, t ^. ideTypeKind & P.prettyPrintKind & toS )+      IdeDeclTypeSynonym s -> (s ^. ideSynonymName . properNameT, s ^. ideSynonymType & prettyTypeT)+      IdeDeclDataConstructor d -> (d ^. ideDtorName . properNameT, d ^. ideDtorType & prettyTypeT)+      IdeDeclTypeClass name -> (runProperNameT name, "class")+      IdeDeclValueOperator (IdeValueOperator op ref precedence associativity typeP) ->+        (runOpNameT op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP)+      IdeDeclTypeOperator (IdeTypeOperator op ref precedence associativity kind) ->         (runOpNameT op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) (toS . P.prettyPrintKind) kind)-            +     complModule = runModuleNameT m      complType = maybe complExpandedType prettyTypeT (annTypeAnnotation ann)-    +     complLocation = annLocation ann      complDocumentation = Nothing-    +     showFixity p a r o =       let asso = case a of             P.Infix -> "infix"@@ -95,7 +97,7 @@   :: P.Qualified (P.ProperName 'P.TypeName) -> Text typeOperatorAliasT i =   toS (P.showQualified P.runProperName i)-  + encodeT :: (ToJSON a) => a -> Text encodeT = toS . decodeUtf8 . encode
src/Language/PureScript/Interactive.hs view
@@ -104,7 +104,7 @@ handleCommand _ _ (BrowseModule moduleName) = handleBrowse moduleName handleCommand _ _ (ShowInfo QueryLoaded)    = handleShowLoadedModules handleCommand _ _ (ShowInfo QueryImport)    = handleShowImportedModules-handleCommand _ _ QuitPSCi                  = P.internalError "`handleCommand QuitPSCi` was called. This is a bug."+handleCommand _ _ _                         = P.internalError "handleCommand: unexpected command"  -- | Reset the application state handleResetState
src/Language/PureScript/Interactive/Completion.hs view
@@ -122,6 +122,7 @@ directiveArg _ Quit        = [] directiveArg _ Reset       = [] directiveArg _ Help        = []+directiveArg _ Paste       = [] directiveArg _ Show        = map CtxFixed replQueryStrings directiveArg _ Type        = [CtxIdentifier] directiveArg _ Kind        = [CtxType]
src/Language/PureScript/Interactive/Directive.hs view
@@ -30,6 +30,7 @@     , (Type   , ["type"])     , (Kind   , ["kind"])     , (Show   , ["show"])+    , (Paste  , ["paste"])     ]  -- |@@ -82,6 +83,7 @@ hasArgument Help = False hasArgument Quit = False hasArgument Reset = False+hasArgument Paste = False hasArgument _ = True  -- |@@ -97,4 +99,5 @@   , (Kind,    "<type>",   "Show the kind of <type>")   , (Show,    "import",   "Show all imported modules")   , (Show,    "loaded",   "Show all loaded modules")+  , (Paste,   "paste",    "Enter multiple lines, terminated by ^D")   ]
src/Language/PureScript/Interactive/IO.hs view
@@ -1,11 +1,11 @@-module Language.PureScript.Interactive.IO where+module Language.PureScript.Interactive.IO (findNodeProcess, getHistoryFilename) where  import Prelude.Compat  import Control.Monad (msum) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import System.Directory (createDirectoryIfMissing, getHomeDirectory, findExecutable)-import System.FilePath (takeDirectory, (</>), isPathSeparator)+import System.FilePath (takeDirectory, (</>))  mkdirp :: FilePath -> IO () mkdirp = createDirectoryIfMissing True . takeDirectory@@ -32,10 +32,3 @@   let filename = home </> ".purescript" </> "psci_history"   mkdirp filename   return filename---- |--- Expands tilde in path.----expandTilde :: FilePath -> IO FilePath-expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory-expandTilde p = return p
src/Language/PureScript/Interactive/Message.hs view
@@ -39,10 +39,14 @@  supportModuleMessage :: String supportModuleMessage = unlines-  [ "PSCi requires the purescript-psci-support package to be installed."+  [ "PSCi requires the psci-support package to be installed."   , "You can install it using Bower as follows:"   , ""   , "  bower i purescript-psci-support --save-dev"+  , ""+  , "Or using psc-package:"+  , ""+  , "  psc-package install psci-support"   , ""   , "For help getting started, visit http://wiki.purescript.org/PSCi"   ]
src/Language/PureScript/Interactive/Module.hs view
@@ -6,7 +6,7 @@ import qualified Language.PureScript as P import           Language.PureScript.Interactive.Types import           System.FilePath (pathSeparator)-import           System.IO.UTF8 (readUTF8File)+import           System.IO.UTF8 (readUTF8FileT)  -- * Support Module @@ -25,7 +25,7 @@ -- loadModule :: FilePath -> IO (Either String [P.Module]) loadModule filename = do-  content <- readUTF8File filename+  content <- readUTF8FileT filename   return $ either (Left . P.prettyPrintMultipleErrors P.defaultPPEOptions) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]  -- |@@ -34,7 +34,7 @@ loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)]) loadAllModules files = do   filesAndContent <- forM files $ \filename -> do-    content <- readUTF8File filename+    content <- readUTF8FileT filename     return (filename, content)   return $ P.parseModulesFromFiles id filesAndContent
src/Language/PureScript/Interactive/Parser.hs view
@@ -62,6 +62,7 @@     Help    -> return ShowHelp     Quit    -> return QuitPSCi     Reset   -> return ResetState+    Paste   -> return PasteLines     Browse  -> BrowseModule <$> parseRest P.moduleName arg     Show    -> ShowInfo <$> parseReplQuery' (trim arg)     Type    -> TypeOf <$> parseRest P.parseValue arg
src/Language/PureScript/Interactive/Types.hs view
@@ -72,46 +72,28 @@ -- Valid Meta-commands for PSCI -- data Command-  -- |-  -- A purescript expression-  --+  -- | A purescript expression   = Expression P.Expr-  -- |-  -- Show the help (ie, list of directives)-  --+  -- | Show the help (ie, list of directives)   | ShowHelp-  -- |-  -- Import a module from a loaded file-  --+  -- | Import a module from a loaded file   | Import ImportedModule-  -- |-  -- Browse a module-  --+  -- | Browse a module   | BrowseModule P.ModuleName-  -- |-  -- Exit PSCI-  --+  -- | Exit PSCI   | QuitPSCi-  -- |-  -- Reset the state of the REPL-  --+  -- | Reset the state of the REPL   | ResetState-  -- |-  -- Add some declarations to the current evaluation context.-  --+  -- | Add some declarations to the current evaluation context   | Decls [P.Declaration]-  -- |-  -- Find the type of an expression-  --+  -- | Find the type of an expression   | TypeOf P.Expr-  -- |-  -- Find the kind of an expression-  --+  -- | Find the kind of an expression   | KindOf P.Type-  -- |-  -- Shows information about the current state of the REPL-  --+  -- | Shows information about the current state of the REPL   | ShowInfo ReplQuery+  -- | Paste multiple lines+  | PasteLines  data ReplQuery   = QueryLoaded@@ -142,4 +124,5 @@   | Type   | Kind   | Show+  | Paste   deriving (Eq, Show)
src/Language/PureScript/Linter/Imports.hs view
@@ -308,7 +308,7 @@     typesRefs       = map (flip TypeRef (Just [])) typesWithoutDctors       ++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors)-  in classRefs ++ typeOpRefs ++ typesRefs ++ valueRefs ++ valueOpRefs+  in sortBy compDecRef $ classRefs ++ typeOpRefs ++ typesRefs ++ valueRefs ++ valueOpRefs    where
src/Language/PureScript/Make.hs view
@@ -149,7 +149,7 @@   lint withPrim   ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do     [desugared] <- desugar externs [withPrim]-    runCheck' env $ typeCheckModule desugared+    runCheck' (emptyCheckState env) $ typeCheckModule desugared   regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated   let mod' = Module ss coms moduleName regrouped exps       corefn = CF.moduleToCoreFn env' mod'
src/Language/PureScript/Parser/Common.hs view
@@ -29,6 +29,12 @@ typeName = ProperName <$> tyname  -- |+-- Parse a proper name for a data constructor.+--+dataConstructorName :: TokenParser (ProperName 'ConstructorName)+dataConstructorName = ProperName <$> dconsname++-- | -- Parse a module name -- moduleName :: TokenParser ModuleName@@ -107,23 +113,26 @@ -- | -- Check that the current identation level matches a predicate ---checkIndentation :: (P.Column -> P.Column -> Bool) -> P.Parsec s ParseState ()-checkIndentation rel = do+checkIndentation+  :: (P.Column -> String)+  -> (P.Column -> P.Column -> Bool)+  -> P.Parsec s ParseState ()+checkIndentation mkMsg rel = do   col <- P.sourceColumn <$> P.getPosition   current <- indentationLevel <$> P.getState-  guard (col `rel` current)+  guard (col `rel` current) P.<?> mkMsg current  -- | -- Check that the current indentation level is past the current mark -- indented :: P.Parsec s ParseState ()-indented = checkIndentation (>) P.<?> "indentation"+indented = checkIndentation (("indentation past column " ++) . show) (>)  -- | -- Check that the current indentation level is at the same indentation as the current mark -- same :: P.Parsec s ParseState ()-same = checkIndentation (==) P.<?> "no indentation"+same = checkIndentation (("indentation at column " ++) . show) (==)  -- | -- Read the comments from the the next token, without consuming it
src/Language/PureScript/Parser/Declarations.hs view
@@ -19,6 +19,7 @@  import Data.Functor (($>)) import Data.Maybe (fromMaybe)+import Data.Text (Text)  import Control.Applicative import Control.Arrow ((+++))@@ -71,7 +72,7 @@   tyArgs <- many (indented *> kindedIdent)   ctors <- P.option [] $ do     indented *> equals-    P.sepBy1 ((,) <$> properName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe+    P.sepBy1 ((,) <$> dataConstructorName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe   return $ DataDeclaration dtype name tyArgs ctors  parseTypeDeclaration :: TokenParser Declaration@@ -281,7 +282,7 @@   :: forall m k    . MonadError MultipleErrors m   => (k -> FilePath)-  -> [(k, String)]+  -> [(k, Text)]   -> m [(k, Module)] parseModulesFromFiles toFilePath input =   flip parU wrapError . inParallel . flip map input $ parseModuleFromFile toFilePath@@ -298,11 +299,11 @@ -- | Parses a single module with FilePath for eventual parsing errors parseModuleFromFile   :: (k -> FilePath)-  -> (k, String)+  -> (k, Text)   -> Either P.ParseError (k, Module) parseModuleFromFile toFilePath (k, content) = do     let filename = toFilePath k-    ts <- lex filename content+    ts <- lex' filename content     m <- runTokenParser filename parseModule ts     pure (k, m) @@ -360,7 +361,7 @@ parseVar = Var <$> C.parseQualified C.parseIdent  parseConstructor :: TokenParser Expr-parseConstructor = Constructor <$> C.parseQualified C.properName+parseConstructor = Constructor <$> C.parseQualified C.dataConstructorName  parseCase :: TokenParser Expr parseCase = Case <$> P.between (reserved "case") (C.indented *> reserved "of") (commaSep1 parseValue)@@ -494,10 +495,10 @@          <|> return id  parseNullaryConstructorBinder :: TokenParser Binder-parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> pure []+parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.dataConstructorName <*> pure []  parseConstructorBinder :: TokenParser Binder-parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> many (C.indented *> parseBinderNoParens)+parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.dataConstructorName <*> many (C.indented *> parseBinderNoParens)  parseObjectBinder:: TokenParser Binder parseObjectBinder = LiteralBinder <$> parseObjectLiteral (C.indented *> parseIdentifierAndBinder)
src/Language/PureScript/Parser/Lexer.hs view
@@ -6,6 +6,7 @@   , Token()   , TokenParser()   , lex+  , lex'   , anyToken   , token   , match@@ -43,6 +44,7 @@   , lname'   , qualifier   , tyname+  , dconsname   , uname   , uname'   , mname@@ -68,6 +70,8 @@  import Data.Char (isSpace, isAscii, isSymbol, isAlphaNum) import Data.Functor.Identity+import Data.Text (Text)+import qualified Data.Text as T  import Language.PureScript.Comments import Language.PureScript.Parser.State@@ -153,31 +157,36 @@ instance Show PositionedToken where   show = prettyPrintToken . ptToken +type Lexer u a = P.Parsec Text u a+ lex :: FilePath -> String -> Either P.ParseError [PositionedToken]-lex f s = updatePositions <$> P.parse parseTokens f s+lex fp = lex' fp . T.pack +lex' :: FilePath -> Text -> Either P.ParseError [PositionedToken]+lex' f s = updatePositions <$> P.parse parseTokens f s+ updatePositions :: [PositionedToken] -> [PositionedToken] updatePositions [] = [] updatePositions (x:xs) = x : zipWith update (x:xs) xs   where   update PositionedToken { ptEndPos = pos } pt = pt { ptPrevEndPos = Just pos } -parseTokens :: P.Parsec String u [PositionedToken]+parseTokens :: Lexer u [PositionedToken] parseTokens = whitespace *> P.many parsePositionedToken <* P.skipMany parseComment <* P.eof -whitespace :: P.Parsec String u ()+whitespace :: Lexer u () whitespace = P.skipMany (P.satisfy isSpace) -parseComment :: P.Parsec String u Comment+parseComment :: Lexer u Comment parseComment = (BlockComment <$> blockComment <|> LineComment <$> lineComment) <* whitespace   where-  blockComment :: P.Parsec String u String+  blockComment :: Lexer u String   blockComment = P.try $ P.string "{-" *> P.manyTill P.anyChar (P.try (P.string "-}")) -  lineComment :: P.Parsec String u String+  lineComment :: Lexer u String   lineComment = P.try $ P.string "--" *> P.manyTill P.anyChar (P.try (void (P.char '\n') <|> P.eof)) -parsePositionedToken :: P.Parsec String u PositionedToken+parsePositionedToken :: Lexer u PositionedToken parsePositionedToken = P.try $ do   comments <- P.many parseComment   pos <- P.getPosition@@ -186,7 +195,7 @@   whitespace   return $ PositionedToken pos pos' Nothing tok comments -parseToken :: P.Parsec String u Token+parseToken :: Lexer u Token parseToken = P.choice   [ P.try $ P.string "<-" *> P.notFollowedBy symbolChar *> pure LArrow   , P.try $ P.string "←"  *> P.notFollowedBy symbolChar *> pure LArrow@@ -225,34 +234,34 @@   ]    where-  parseLName :: P.Parsec String u String+  parseLName :: Lexer u String   parseLName = (:) <$> identStart <*> P.many identLetter -  parseUName :: P.Parsec String u String+  parseUName :: Lexer u String   parseUName = (:) <$> P.upper <*> P.many identLetter -  parseSymbol :: P.Parsec String u String+  parseSymbol :: Lexer u String   parseSymbol = P.many1 symbolChar -  identStart :: P.Parsec String u Char+  identStart :: Lexer u Char   identStart = P.lower <|> P.oneOf "_" -  identLetter :: P.Parsec String u Char+  identLetter :: Lexer u Char   identLetter = P.alphaNum <|> P.oneOf "_'" -  symbolChar :: P.Parsec String u Char+  symbolChar :: Lexer u Char   symbolChar = P.satisfy isSymbolChar -  parseCharLiteral :: P.Parsec String u Char+  parseCharLiteral :: Lexer u Char   parseCharLiteral = PT.charLiteral tokenParser -  parseStringLiteral :: P.Parsec String u String+  parseStringLiteral :: Lexer u String   parseStringLiteral = blockString <|> PT.stringLiteral tokenParser     where     delimiter   = P.try (P.string "\"\"\"")     blockString = delimiter >> P.manyTill P.anyChar delimiter -  parseNumber :: P.Parsec String u (Either Integer Double)+  parseNumber :: Lexer u (Either Integer Double)   parseNumber = (consumeLeadingZero >> P.parserZero) <|>                   (Right <$> P.try (PT.float tokenParser) <|>                   Left <$> P.try (PT.natural tokenParser))@@ -266,7 +275,7 @@ -- | -- We use Text.Parsec.Token to implement the string and number lexemes ---langDef :: PT.GenLanguageDef String u Identity+langDef :: PT.GenLanguageDef Text u Identity langDef = PT.LanguageDef   { PT.reservedNames   = []   , PT.reservedOpNames = []@@ -284,7 +293,7 @@ -- | -- A token parser based on the language definition ---tokenParser :: PT.GenTokenParser String u Identity+tokenParser :: PT.GenTokenParser Text u Identity tokenParser = PT.makeTokenParser langDef  type TokenParser a = P.Parsec [PositionedToken] ParseState a@@ -448,6 +457,12 @@  tyname :: TokenParser String tyname = token go P.<?> "type name"+  where+  go (UName s) = Just s+  go _ = Nothing++dconsname :: TokenParser String+dconsname = token go P.<?> "data constructor name"   where   go (UName s) = Just s   go _ = Nothing
src/Language/PureScript/Pretty/Types.hs view
@@ -3,7 +3,9 @@ -- module Language.PureScript.Pretty.Types   ( typeAsBox+  , suggestedTypeAsBox   , prettyPrintType+  , prettyPrintSuggestedType   , typeAtomAsBox   , prettyPrintTypeAtom   , prettyPrintRowWith@@ -27,23 +29,6 @@  import Text.PrettyPrint.Boxes hiding ((<+>)) -typeLiterals :: Pattern () Type Box-typeLiterals = mkPattern match-  where-  match TypeWildcard{} = Just $ text "_"-  match (TypeVar var) = Just $ text var-  match (TypeLevelString s) = Just . text $ show s-  match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row-  match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor-  match (TUnknown u) = Just $ text $ 't' : show u-  match (Skolem name s _ _) = Just $ text $ name ++ show s-  match REmpty = Just $ text "()"-  match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row-  match (BinaryNoParensType op l r) =-    Just $ typeAsBox l <> text " " <> typeAsBox op <> text " " <> typeAsBox r-  match (TypeOp op) = Just $ text $ showQualified runOpName op-  match _ = Nothing- constraintsAsBox :: [Constraint] -> Box -> Box constraintsAsBox [con] ty = text "(" <> constraintAsBox con `before` (text ") => " <> ty) constraintsAsBox 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 @@   match (ParensInType ty) = Just ((), ty)   match _ = Nothing -matchTypeAtom :: Pattern () Type Box-matchTypeAtom = typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) matchType--matchType :: Pattern () Type Box-matchType = buildPrettyPrinter operators matchTypeAtom+matchTypeAtom :: Bool -> Pattern () Type Box+matchTypeAtom suggesting =+    typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) (matchType suggesting)   where+    typeLiterals :: Pattern () Type Box+    typeLiterals = mkPattern match where+      match TypeWildcard{} = Just $ text "_"+      match (TypeVar var) = Just $ text var+      match (TypeLevelString s) = Just . text $ show s+      match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row+      match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor+      match (TUnknown u)+        | suggesting = Just $ text "_"+        | otherwise = Just $ text $ 't' : show u+      match (Skolem name s _ _)+        | suggesting =  Just $ text name+        | otherwise = Just $ text $ name ++ show s+      match REmpty = Just $ text "()"+      match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row+      match (BinaryNoParensType op l r) =+        Just $ typeAsBox l <> text " " <> typeAsBox op <> text " " <> typeAsBox r+      match (TypeOp op) = Just $ text $ showQualified runOpName op+      match _ = Nothing++matchType :: Bool -> Pattern () Type Box+matchType = buildPrettyPrinter operators . matchTypeAtom where   operators :: OperatorTable () Type Box   operators =     OperatorTable [ [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ]@@ -152,7 +157,7 @@ typeAtomAsBox :: Type -> Box typeAtomAsBox   = fromMaybe (internalError "Incomplete pattern")-  . PA.pattern matchTypeAtom ()+  . PA.pattern (matchTypeAtom False) ()   . insertPlaceholders  -- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses@@ -160,11 +165,21 @@ prettyPrintTypeAtom = render . typeAtomAsBox  typeAsBox :: Type -> Box-typeAsBox+typeAsBox = typeAsBoxImpl False++suggestedTypeAsBox :: Type -> Box+suggestedTypeAsBox = typeAsBoxImpl True++typeAsBoxImpl :: Bool -> Type -> Box+typeAsBoxImpl suggesting   = fromMaybe (internalError "Incomplete pattern")-  . PA.pattern matchType ()+  . PA.pattern (matchType suggesting) ()   . insertPlaceholders --- | Generate a pretty-printed string representing a Type+-- | Generate a pretty-printed string representing a 'Type' prettyPrintType :: Type -> String-prettyPrintType = render . typeAsBox+prettyPrintType = render . typeAsBoxImpl False++-- | Generate a pretty-printed string representing a suggested 'Type'+prettyPrintSuggestedType :: Type -> String+prettyPrintSuggestedType = render . typeAsBoxImpl True
src/Language/PureScript/Sugar/TypeClasses/Deriving.hs view
@@ -13,7 +13,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Supply.Class (MonadSupply) -import Data.List (foldl', find, sortBy)+import Data.List (foldl', find, sortBy, unzip5) import Data.Maybe (fromMaybe) import Data.Ord (comparing) @@ -58,9 +58,14 @@   | className == Qualified (Just dataNewtype) (ProperName "Newtype")   , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy   , mn == fromMaybe mn mn'-  = do-    (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon args unwrappedTy-    return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst)+  = do (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon args unwrappedTy+       return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst)+deriveInstance mn ds (TypeInstanceDeclaration nm deps className [actualTy, repTy] DerivedInstance)+  | className == Qualified (Just dataGenericRep) (ProperName C.generic)+  , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor actualTy+  , mn == fromMaybe mn mn'+  = do (inst, inferredRepTy) <- deriveGenericRep mn ds tyCon args repTy+       return $ TypeInstanceDeclaration nm deps className [actualTy, inferredRepTy] (ExplicitInstance inst) deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)   = throwError . errorMessage $ CannotDerive className tys deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@(_ : _) NewtypeInstance)@@ -122,6 +127,9 @@ dataGeneric :: ModuleName dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ] +dataGenericRep :: ModuleName+dataGenericRep = ModuleName [ ProperName "Data", ProperName "Generic", ProperName "Rep" ]+ dataMaybe :: ModuleName dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ] @@ -304,6 +312,187 @@     mkGenVar :: Ident -> Expr     mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic])) +deriveGenericRep+  :: forall m+   . (MonadError MultipleErrors m, MonadSupply m)+  => ModuleName+  -> [Declaration]+  -> ProperName 'TypeName+  -> [Type]+  -> Type+  -> m ([Declaration], Type)+deriveGenericRep mn ds tyConNm tyConArgs repTy = do+    checkIsWildcard tyConNm repTy+    go =<< findTypeDecl tyConNm ds+  where+    go :: Declaration -> m ([Declaration], Type)+    go (DataDeclaration _ _ args dctors) = do+      x <- freshIdent "x"+      (reps, to, from) <- unzip3 <$> traverse makeInst dctors+      let rep = toRepTy reps+          inst | null reps =+                   -- If there are no cases, spin+                   [ ValueDeclaration (Ident "to") Public [] $ Right $+                       lamCase x [ CaseAlternative [NullBinder]+                                                   (Right (App toName (Var (Qualified Nothing x))))+                                 ]+                   , ValueDeclaration (Ident "from") Public [] $ Right $+                       lamCase x [ CaseAlternative [NullBinder]+                                                   (Right (App fromName (Var (Qualified Nothing x))))+                                 ]+                   ]+               | otherwise =+                   [ ValueDeclaration (Ident "to") Public [] $ Right $+                       lamCase x (zipWith ($) (map underBinder (sumBinders (length dctors))) to)+                   , ValueDeclaration (Ident "from") Public [] $ Right $+                       lamCase x (zipWith ($) (map underExpr (sumExprs (length dctors))) from)+                   ]++          subst = zipWith ((,) . fst) args tyConArgs+      return (inst, replaceAllTypeVars subst rep)+    go (PositionedDeclaration _ _ d) = go d+    go _ = internalError "deriveGenericRep go: expected DataDeclaration"++    select :: (a -> a) -> (a -> a) -> Int -> [a -> a]+    select _ _ 0 = []+    select _ _ 1 = [id]+    select l r n = take (n - 1) (iterate (r .) l) ++ [compN (n - 1) r]++    sumBinders :: Int -> [Binder -> Binder]+    sumBinders = select (ConstructorBinder inl . pure) (ConstructorBinder inr . pure)++    sumExprs :: Int -> [Expr -> Expr]+    sumExprs = select (App (Constructor inl)) (App (Constructor inr))++    compN :: Int -> (a -> a) -> a -> a+    compN 0 _ = id+    compN n f = f . compN (n - 1) f++    makeInst+      :: (ProperName 'ConstructorName, [Type])+      -> m (Type, CaseAlternative, CaseAlternative)+    makeInst (ctorName, args) = do+        (ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args+        return ( TypeApp (TypeApp (TypeConstructor constructor)+                                  (TypeLevelString (runProperName ctorName)))+                         ctorTy+               , CaseAlternative [ ConstructorBinder constructor [matchProduct] ]+                                 (Right (foldl App (Constructor (Qualified (Just mn) ctorName)) ctorArgs))+               , CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) matchCtor ]+                                 (Right (constructor' mkProduct))+               )++    makeProduct+      :: [Type]+      -> m (Type, Binder, [Expr], [Binder], Expr)+    makeProduct [] =+      pure (noArgs, NullBinder, [], [], noArgs')+    makeProduct args = do+      (tys, bs1, es1, bs2, es2) <- unzip5 <$> traverse makeArg args+      pure ( foldr1 (\f -> TypeApp (TypeApp (TypeConstructor productName) f)) tys+           , foldr1 (\b1 b2 -> ConstructorBinder productName [b1, b2]) bs1+           , es1+           , bs2+           , foldr1 (\e1 -> App (App (Constructor productName) e1)) es2+           )++    makeArg :: Type -> m (Type, Binder, Expr, Binder, Expr)+    makeArg arg | Just rec <- objectType arg = do+      let fields = decomposeRec rec+      fieldNames <- traverse freshIdent (map fst fields)+      pure ( TypeApp (TypeConstructor record)+               (foldr1 (\f -> TypeApp (TypeApp (TypeConstructor productName) f))+                 (map (\(name, ty) ->+                   TypeApp (TypeApp (TypeConstructor field) (TypeLevelString name)) ty) fields))+           , ConstructorBinder record+               [ foldr1 (\b1 b2 -> ConstructorBinder productName [b1, b2])+                   (map (\ident -> ConstructorBinder field [VarBinder ident]) fieldNames)+               ]+           , Literal . ObjectLiteral $+                zipWith (\(name, _) ident -> (name, Var (Qualified Nothing ident))) fields fieldNames+           , LiteralBinder . ObjectLiteral $+                 zipWith (\(name, _) ident -> (name, VarBinder ident)) fields fieldNames+           , record' $+               foldr1 (\e1 -> App (App (Constructor productName) e1))+                 (map (field' . Var . Qualified Nothing) fieldNames)+           )+    makeArg arg = do+      argName <- freshIdent "arg"+      pure ( TypeApp (TypeConstructor argument) arg+           , ConstructorBinder argument [ VarBinder argName ]+           , Var (Qualified Nothing argName)+           , VarBinder argName+           , argument' (Var (Qualified Nothing argName))+           )++    underBinder :: (Binder -> Binder) -> CaseAlternative -> CaseAlternative+    underBinder f (CaseAlternative bs e) = CaseAlternative (map f bs) e++    underExpr :: (Expr -> Expr) -> CaseAlternative -> CaseAlternative+    underExpr f (CaseAlternative b (Right e)) = CaseAlternative b (Right (f e))+    underExpr _ _ = internalError "underExpr: expected Right"++    toRepTy :: [Type] -> Type+    toRepTy [] = noCtors+    toRepTy [only] = only+    toRepTy ctors = foldr1 (\f -> TypeApp (TypeApp sumCtor f)) ctors++    toName :: Expr+    toName = Var (Qualified (Just dataGenericRep) (Ident "to"))++    fromName :: Expr+    fromName = Var (Qualified (Just dataGenericRep) (Ident "from"))++    noCtors :: Type+    noCtors = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "NoConstructors"))++    noArgs :: Type+    noArgs = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "NoArguments"))++    noArgs' :: Expr+    noArgs' = Constructor (Qualified (Just dataGenericRep) (ProperName "NoArguments"))++    sumCtor :: Type+    sumCtor = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "Sum"))++    inl :: Qualified (ProperName 'ConstructorName)+    inl = Qualified (Just dataGenericRep) (ProperName "Inl")++    inr :: Qualified (ProperName 'ConstructorName)+    inr = Qualified (Just dataGenericRep) (ProperName "Inr")++    productName :: Qualified (ProperName ty)+    productName = Qualified (Just dataGenericRep) (ProperName "Product")++    constructor :: Qualified (ProperName ty)+    constructor = Qualified (Just dataGenericRep) (ProperName "Constructor")++    constructor' :: Expr -> Expr+    constructor' = App (Constructor constructor)++    argument :: Qualified (ProperName ty)+    argument = Qualified (Just dataGenericRep) (ProperName "Argument")++    argument' :: Expr -> Expr+    argument' = App (Constructor argument)++    record :: Qualified (ProperName ty)+    record = Qualified (Just dataGenericRep) (ProperName "Rec")++    record' :: Expr -> Expr+    record' = App (Constructor record)++    field :: Qualified (ProperName ty)+    field = Qualified (Just dataGenericRep) (ProperName "Field")++    field' :: Expr -> Expr+    field' = App (Constructor field)++checkIsWildcard :: MonadError MultipleErrors m => ProperName 'TypeName -> Type -> m ()+checkIsWildcard _ (TypeWildcard _) = return ()+checkIsWildcard tyConNm _ =+  throwError . errorMessage $ ExpectedWildcard tyConNm+ deriveEq ::   forall m. (MonadError MultipleErrors m, MonadSupply m)   => ModuleName@@ -451,7 +640,7 @@   -> Type   -> m ([Declaration], Type) deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do-    checkIsWildcard unwrappedTy+    checkIsWildcard tyConNm unwrappedTy     go =<< findTypeDecl tyConNm ds   where     go :: Declaration -> m ([Declaration], Type)@@ -476,12 +665,6 @@       return (inst, replaceAllTypeVars subst ty)     go (PositionedDeclaration _ _ d) = go d     go _ = internalError "deriveNewtype go: expected DataDeclaration"--    checkIsWildcard :: Type -> m ()-    checkIsWildcard (TypeWildcard _) =-      return ()-    checkIsWildcard _ =-      throwError . errorMessage $ NonWildcardNewtypeInstance tyConNm  findTypeDecl   :: (MonadError MultipleErrors m)
src/Language/PureScript/TypeChecker.hs view
@@ -11,7 +11,7 @@  import Prelude.Compat -import Control.Monad (when, unless, void, forM, forM_)+import Control.Monad (when, unless, void, forM) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), modify) import Control.Monad.Supply.Class (MonadSupply)@@ -279,7 +279,6 @@     return d   go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do     traverse_ (checkTypeClassInstance moduleName) tys-    forM_ deps $ traverse_ (checkTypeClassInstance moduleName) . constraintArgs     checkOrphanInstance dictName className tys     _ <- traverseTypeInstanceBody checkInstanceMembers body     let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps)@@ -313,6 +312,7 @@     where     checkType :: Type -> Bool     checkType (TypeVar _) = False+    checkType (TypeLevelString _) = False     checkType (TypeConstructor (Qualified (Just mn'') _)) = moduleName == mn''     checkType (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance"     checkType (TypeApp t1 _) = checkType t1
src/Language/PureScript/TypeChecker/Entailment.hs view
@@ -5,8 +5,10 @@ -- module Language.PureScript.TypeChecker.Entailment   ( InstanceContext+  , SolverOptions(..)   , replaceTypeClassDictionaries   , newDictionaries+  , entails   ) where  import Prelude.Compat@@ -56,7 +58,7 @@    . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)   => Bool   -> Expr-  -> m (Expr, [(Ident, Constraint)])+  -> m (Expr, [(Ident, InstanceContext, Constraint)]) replaceTypeClassDictionaries shouldGeneralize expr = flip evalStateT M.empty $ do     -- Loop, deferring any unsolved constraints, until there are no more     -- constraints which can be solved, then make a generalization pass.@@ -70,18 +72,18 @@     -- This pass solves constraints where possible, deferring constraints if not.     deferPass :: Expr -> StateT InstanceContext m (Expr, Any)     deferPass = fmap (second fst) . runWriterT . f where-      f :: Expr -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr+      f :: Expr -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr       (_, f, _) = everywhereOnValuesTopDownM return (go True) return      -- This pass generalizes any remaining constraints-    generalizePass :: Expr -> StateT InstanceContext m (Expr, [(Ident, Constraint)])+    generalizePass :: Expr -> StateT InstanceContext m (Expr, [(Ident, InstanceContext, Constraint)])     generalizePass = fmap (second snd) . runWriterT . f where-      f :: Expr -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr+      f :: Expr -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr       (_, f, _) = everywhereOnValuesTopDownM return (go False) return -    go :: Bool -> Expr -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr-    go deferErrors dict@(TypeClassDictionary _ _ hints) =-      rethrow (addHints hints) $ entails shouldGeneralize deferErrors dict+    go :: Bool -> Expr -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr+    go deferErrors (TypeClassDictionary constraint context hints) =+      rethrow (addHints hints) $ entails (SolverOptions shouldGeneralize deferErrors) constraint context hints     go _ other = return other  -- | Three options for how we can handle a constraint, depending on the mode we're in.@@ -93,18 +95,29 @@   | Deferred   -- ^ We couldn't solve this constraint right now, so it has been deferred --- |--- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,+-- | Options for the constraint solver+data SolverOptions = SolverOptions+  { solverShouldGeneralize :: Bool+  -- ^ Should the solver be allowed to generalize over unsolved constraints?+  , solverDeferErrors      :: Bool+  -- ^ Should the solver be allowed to defer errors by skipping constraints?+  }++-- | Check that the current set of type class dictionaries entail the specified type class goal, and, if so, -- return a type class dictionary reference.--- entails   :: forall m    . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)-  => Bool-  -> Bool-  -> Expr-  -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr-entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hints) =+  => SolverOptions+  -- ^ Solver options+  -> Constraint+  -- ^ The constraint to solve+  -> InstanceContext+  -- ^ The contexts in which to solve the constraint+  -> [ErrorMessageHint]+  -- ^ Error message hints to apply to any instance errors+  -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr+entails SolverOptions{..} constraint context hints =     solve constraint   where     forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]@@ -123,10 +136,10 @@     valUndefined :: Expr     valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined)) -    solve :: Constraint -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr+    solve :: Constraint -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr     solve con = go 0 con       where-        go :: Int -> Constraint -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr+        go :: Int -> Constraint -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr         go work (Constraint className' tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'         go work con'@(Constraint className' tys' conInfo) = WriterT . StateT . (withErrorMessageHint (ErrorSolvingConstraint con') .) . runStateT . runWriterT $ do             -- We might have unified types by solving other constraints, so we need to@@ -137,8 +150,10 @@             inferred <- lift get             -- We need information about functional dependencies, so we have to look up the class             -- name in the environment:-            let findClass = fromMaybe (internalError "entails: type class not found in environment") . M.lookup className'-            TypeClassData{ typeClassDependencies } <- lift . lift $ gets (findClass . typeClasses . checkEnv)+            classesInScope <- lift . lift $ gets (typeClasses . checkEnv)+            TypeClassData{ typeClassDependencies } <- case M.lookup className' classesInScope of+              Nothing -> throwError . errorMessage $ UnknownClass className'+              Just tcd -> pure tcd             let instances =                   [ (substs, tcd)                   | tcd <- forClassName (combineContexts context inferred) className' tys''@@ -179,7 +194,7 @@                 let newContext = mkContext newDicts                 modify (combineContexts newContext)                 -- Mark this constraint for generalization-                tell (mempty, [(ident, unsolved)])+                tell (mempty, [(ident, context, unsolved)])                 return (Var qident)               Deferred ->                 -- Constraint was deferred, just return the dictionary unchanged,@@ -219,10 +234,10 @@              unique :: [Type] -> [(a, TypeClassDictionaryInScope)] -> m (EntailsResult a)             unique tyArgs []-              | deferErrors = return Deferred+              | solverDeferErrors = return Deferred               -- We need a special case for nullary type classes, since we want               -- to generalize over Partial constraints.-              | shouldGeneralize && (null tyArgs || any canBeGeneralized tyArgs) = return (Unsolved (Constraint className' tyArgs conInfo))+              | solverShouldGeneralize && (null tyArgs || any canBeGeneralized tyArgs) = return (Unsolved (Constraint className' tyArgs conInfo))               | otherwise = throwError . errorMessage $ NoInstanceFound (Constraint className' tyArgs conInfo)             unique _      [(a, dict)] = return $ Solved a dict             unique tyArgs tcds@@ -233,7 +248,6 @@              canBeGeneralized :: Type -> Bool             canBeGeneralized TUnknown{} = True-            canBeGeneralized Skolem{} = True             canBeGeneralized _ = False              -- |@@ -251,7 +265,7 @@             -- Create dictionaries for subgoals which still need to be solved by calling go recursively             -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type             -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.-            solveSubgoals :: Matching Type -> Maybe [Constraint] -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) (Maybe [Expr])+            solveSubgoals :: Matching Type -> Maybe [Constraint] -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) (Maybe [Expr])             solveSubgoals _ Nothing = return Nothing             solveSubgoals subst (Just subgoals) =               Just <$> traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars (M.toList subst)))) subgoals@@ -268,7 +282,6 @@           App (Accessor (C.__superclass_ ++ showQualified runProperName superclassName ++ "_" ++ show index)                         dict)               valUndefined-entails _ _ _ = internalError "entails: expected TypeClassDictionary"  -- Check if an instance matches our list of types, allowing for types -- to be solved via functional dependencies. If the types match, we return a
src/Language/PureScript/TypeChecker/Monad.hs view
@@ -257,11 +257,11 @@  -- | Run a computation in the typechecking monad, starting with an empty @Environment@ runCheck :: (Functor m) => StateT CheckState m a -> m (a, Environment)-runCheck = runCheck' initEnvironment+runCheck = runCheck' (emptyCheckState initEnvironment)  -- | Run a computation in the typechecking monad, failing with an error, or succeeding with a return value and the final @Environment@.-runCheck' :: (Functor m) => Environment -> StateT CheckState m a -> m (a, Environment)-runCheck' env check = second checkEnv <$> runStateT check (emptyCheckState env)+runCheck' :: (Functor m) => CheckState -> StateT CheckState m a -> m (a, Environment)+runCheck' st check = second checkEnv <$> runStateT check st  -- | Make an assertion, failing with an error message guardWith :: (MonadError e m) => e -> Bool -> m ()
src/Language/PureScript/TypeChecker/Subsumption.hs view
@@ -1,6 +1,8 @@--- |--- Subsumption checking---+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}++-- | Subsumption checking module Language.PureScript.TypeChecker.Subsumption   ( subsumes   ) where@@ -25,72 +27,120 @@ import Language.PureScript.TypeChecker.Unify import Language.PureScript.Types +-- | Subsumption can operate in two modes:+--+-- * Elaboration mode, in which we try to insert type class dictionaries+-- * No-elaboration mode, in which we do not insert dictionaries+--+-- Some subsumption rules apply in both modes, and others are specific to+-- certain modes.+--+-- The subsumption algorithm follows the structure of the types in question,+-- and we can switch into no-elaboration mode when we move under a type+-- constructor where we can no longer insert dictionaries, e.g. into the fields+-- of a record.+data Mode = Elaborate | NoElaborate++-- | Value-level proxies for the two modes+data ModeSing (mode :: Mode) where+  SElaborate   :: ModeSing 'Elaborate+  SNoElaborate :: ModeSing 'NoElaborate++-- | This type family tracks what evidence we return from 'subsumes' for each+-- mode.+type family Coercion (mode :: Mode) where+  -- When elaborating, we generate a coercion+  Coercion 'Elaborate = Expr -> Expr+  -- When we're not elaborating, we don't generate coercions+  Coercion 'NoElaborate = ()++-- | The default coercion for each mode.+defaultCoercion :: ModeSing mode -> Coercion mode+defaultCoercion SElaborate   = id+defaultCoercion SNoElaborate = ()+ -- | Check that one type subsumes another, rethrowing errors to provide a better error message-subsumes :: (MonadError MultipleErrors m, MonadState CheckState m) => Maybe Expr -> Type -> Type -> m (Maybe Expr)-subsumes val ty1 ty2 = withErrorMessageHint (ErrorInSubsumption ty1 ty2) $ subsumes' val ty1 ty2+subsumes+  :: (MonadError MultipleErrors m, MonadState CheckState m)+  => Type+  -> Type+  -> m (Expr -> Expr)+subsumes ty1 ty2 =+  withErrorMessageHint (ErrorInSubsumption ty1 ty2) $+    subsumes' SElaborate ty1 ty2  -- | Check that one type subsumes another-subsumes' :: (MonadError MultipleErrors m, MonadState CheckState m) =>-  Maybe Expr ->-  Type ->-  Type ->-  m (Maybe Expr)-subsumes' val (ForAll ident ty1 _) ty2 = do+subsumes'+  :: (MonadError MultipleErrors m, MonadState CheckState m)+  => ModeSing mode+  -> Type+  -> Type+  -> m (Coercion mode)+subsumes' mode (ForAll ident ty1 _) ty2 = do   replaced <- replaceVarWithUnknown ident ty1-  subsumes val replaced ty2-subsumes' val ty1 (ForAll ident ty2 sco) =+  subsumes' mode replaced ty2+subsumes' mode ty1 (ForAll ident ty2 sco) =   case sco of     Just sco' -> do       sko <- newSkolemConstant       let sk = skolemize ident sko sco' Nothing ty2-      subsumes val ty1 sk+      subsumes' mode ty1 sk     Nothing -> internalError "subsumes: unspecified skolem scope"-subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do-  _ <- subsumes Nothing arg2 arg1-  _ <- subsumes Nothing ret1 ret2-  return val-subsumes' val (KindedType ty1 _) ty2 =-  subsumes val ty1 ty2-subsumes' val ty1 (KindedType ty2 _) =-  subsumes val ty1 ty2-subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do+subsumes' mode (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do+  subsumes' SNoElaborate arg2 arg1+  subsumes' SNoElaborate ret1 ret2+  -- Nothing was elaborated, return the default coercion+  return (defaultCoercion mode)+subsumes' mode (KindedType ty1 _) ty2 =+  subsumes' mode ty1 ty2+subsumes' mode ty1 (KindedType ty2 _) =+  subsumes' mode ty1 ty2+-- Only check subsumption for constrained types when elaborating.+-- Otherwise fall back to unification.+subsumes' SElaborate (ConstrainedType constraints ty1) ty2 = do   dicts <- getTypeClassDictionaries   hints <- gets checkHints-  subsumes' (Just $ foldl App val (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) ty1 ty2-subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyRecord && f2 == tyRecord = do-  let-    (ts1, r1') = rowToList r1-    (ts2, r2') = rowToList r2-    ts1' = sortBy (comparing fst) ts1-    ts2' = sortBy (comparing fst) ts2-  -- For { ts1 | r1 } to subsume { ts2 | r2 } when r1 is empty (= we're working with a closed row),-  -- every property in ts2 must appear in ts1. If not, then the candidate expression is missing a required property.-  -- Conversely, when r2 is empty, every property in ts1 must appear in ts2, or else the expression has-  -- an additional property which is not allowed.-  when (r1' == REmpty)-    (for_ (firstMissingProp ts2' ts1') (throwError . errorMessage . PropertyIsMissing . fst))-  when (r2' == REmpty)-    (for_ (firstMissingProp ts1' ts2') (throwError . errorMessage . AdditionalProperty . fst))-  go ts1' ts2' r1' r2'-  return val+  elaborate <- subsumes' SElaborate ty1 ty2+  let addDicts val = foldl App val (map (\cs -> TypeClassDictionary cs dicts hints) constraints)+  return (elaborate . addDicts)+subsumes' mode (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyRecord && f2 == tyRecord = do+    let+      (ts1, r1') = rowToList r1+      (ts2, r2') = rowToList r2+      ts1' = sortBy (comparing fst) ts1+      ts2' = sortBy (comparing fst) ts2+    -- For { ts1 | r1 } to subsume { ts2 | r2 } when r1 is empty (= we're working with a closed row),+    -- every property in ts2 must appear in ts1. If not, then the candidate expression is missing a required property.+    -- Conversely, when r2 is empty, every property in ts1 must appear in ts2, or else the expression has+    -- an additional property which is not allowed.+    when (r1' == REmpty)+      (for_ (firstMissingProp ts2' ts1') (throwError . errorMessage . PropertyIsMissing . fst))+    when (r2' == REmpty)+      (for_ (firstMissingProp ts1' ts2') (throwError . errorMessage . AdditionalProperty . fst))+    go ts1' ts2' r1' r2'+    -- Nothing was elaborated, return the default coercion+    return (defaultCoercion mode)   where-  go [] ts2 r1' r2' = unifyTypes r1' (rowFromList (ts2, r2'))-  go ts1 [] r1' r2' = unifyTypes r2' (rowFromList (ts1, r1'))-  go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1' r2'-    | p1 == p2 = do _ <- subsumes Nothing ty1 ty2-                    go ts1 ts2 r1' r2'-    | p1 < p2 = do rest <- freshType-                   -- What happens next is a bit of a hack.-                   -- TODO: in the new type checker, object properties will probably be restricted to being monotypes-                   -- in which case, this branch of the subsumes function should not even be necessary.-                   unifyTypes r2' (RCons p1 ty1 rest)-                   go ts1 ((p2, ty2) : ts2) r1' rest-    | otherwise = do rest <- freshType-                     unifyTypes r1' (RCons p2 ty2 rest)-                     go ((p1, ty1) : ts1) ts2 rest r2'-  -- Find the first property that's in the first list (of tuples) but not in the second-  firstMissingProp t1 t2 = fst <$> uncons (minusBy' (comparing fst) t1 t2)-subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyRecord = subsumes val ty2 ty1-subsumes' val ty1 ty2 = do+    go [] ts2 r1' r2' = unifyTypes r1' (rowFromList (ts2, r2'))+    go ts1 [] r1' r2' = unifyTypes r2' (rowFromList (ts1, r1'))+    go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1' r2'+      | p1 == p2 = do subsumes' SNoElaborate ty1 ty2+                      go ts1 ts2 r1' r2'+      | p1 < p2 = do rest <- freshType+                     -- What happens next is a bit of a hack.+                     -- TODO: in the new type checker, object properties will probably be restricted to being monotypes+                     -- in which case, this branch of the subsumes function should not even be necessary.+                     unifyTypes r2' (RCons p1 ty1 rest)+                     go ts1 ((p2, ty2) : ts2) r1' rest+      | otherwise = do rest <- freshType+                       unifyTypes r1' (RCons p2 ty2 rest)+                       go ((p1, ty1) : ts1) ts2 rest r2'++    -- Find the first property that's in the first list (of tuples) but not in the second+    firstMissingProp t1 t2 = fst <$> uncons (minusBy' (comparing fst) t1 t2)+subsumes' mode ty1 ty2@(TypeApp obj _) | obj == tyRecord =+  subsumes' mode ty2 ty1+subsumes' mode ty1 ty2 = do   unifyTypes ty1 ty2-  return val+  -- Nothing was elaborated, return the default coercion+  return (defaultCoercion mode)
+ src/Language/PureScript/TypeChecker/TypeSearch.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}++module Language.PureScript.TypeChecker.TypeSearch+  ( typeSearch+  ) where++import           Protolude++import           Control.Monad.Writer+import qualified Data.Map                                    as Map+import qualified Language.PureScript.TypeChecker.Entailment  as Entailment++import qualified Language.PureScript.TypeChecker.Monad       as TC+import           Language.PureScript.TypeChecker.Subsumption+import           Language.PureScript.TypeChecker.Unify       as P++import           Control.Monad.Supply                        as P+import           Language.PureScript.AST                     as P+import           Language.PureScript.Environment             as P+import           Language.PureScript.Errors                  as P+import           Language.PureScript.Names                   as P+import           Language.PureScript.TypeChecker.Skolems     as Skolem+import           Language.PureScript.TypeChecker.Synonyms    as P+import           Language.PureScript.Types                   as P++checkInEnvironment+  :: Environment+  -> TC.CheckState+  -> StateT TC.CheckState (SupplyT (WriterT b (Except P.MultipleErrors))) a+  -> Maybe (a, Environment)+checkInEnvironment env st =+  either (const Nothing) Just+  . runExcept+  . evalWriterT+  . P.evalSupplyT 0+  . TC.runCheck' (st { TC.checkEnv = env })++evalWriterT :: Monad m => WriterT b m r -> m r+evalWriterT m = liftM fst (runWriterT m)++checkSubsume+  :: Maybe [(P.Ident, Entailment.InstanceContext, P.Constraint)]+  -- ^ Additional constraints we need to satisfy+  -> P.Environment+  -- ^ The Environment which contains the relevant definitions and typeclasses+  -> TC.CheckState+  -- ^ The typechecker state+  -> P.Type+  -- ^ The user supplied type+  -> P.Type+  -- ^ The type supplied by the environment+  -> Maybe ((P.Expr, [(P.Ident, Entailment.InstanceContext, P.Constraint)]), P.Environment)+checkSubsume unsolved env st userT envT = checkInEnvironment env st $ do+  let initializeSkolems =+        Skolem.introduceSkolemScope+        <=< P.replaceAllTypeSynonyms+        <=< P.replaceTypeWildcards++  userT' <- initializeSkolems userT+  envT' <- initializeSkolems envT++  let dummyExpression = P.Var (P.Qualified Nothing (P.Ident "x"))++  elab <- subsumes envT' userT'+  subst <- gets TC.checkSubstitution+  let expP = P.overTypes (P.substituteType subst) (elab dummyExpression)++  -- Now check that any unsolved constraints have not become impossible+  (traverse_ . traverse_) (\(_, context, constraint) -> do+    let constraint' = P.mapConstraintArgs (map (P.substituteType subst)) constraint+    flip evalStateT Map.empty . evalWriterT $+      Entailment.entails+        (Entailment.SolverOptions+          { solverShouldGeneralize = True+          , solverDeferErrors      = False+          }) constraint' context []) unsolved++  -- Finally, check any constraints which were found during elaboration+  Entailment.replaceTypeClassDictionaries (isJust unsolved) expP++typeSearch+  :: Maybe [(P.Ident, Entailment.InstanceContext, P.Constraint)]+  -- ^ Additional constraints we need to satisfy+  -> P.Environment+  -- ^ The Environment which contains the relevant definitions and typeclasses+  -> TC.CheckState+  -- ^ The typechecker state+  -> P.Type+  -- ^ The type we are looking for+  -> Map (P.Qualified P.Ident) P.Type+typeSearch unsolved env st type' =+  Map.mapMaybe (\(x, _, _) -> checkSubsume unsolved env st type' x $> x) (P.names env)
src/Language/PureScript/TypeChecker/Types.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NamedFieldPuns #-} @@ -27,13 +28,16 @@  import Prelude.Compat +import Control.Arrow (first, second, (***)) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), gets) import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.Writer.Class (MonadWriter(..)) +import Data.Bifunctor (bimap) import Data.Either (lefts, rights)+import Data.Functor (($>)) import Data.List (transpose, nub, (\\), partition, delete) import Data.Maybe (fromMaybe) import qualified Data.Map as M@@ -53,9 +57,11 @@ import Language.PureScript.TypeChecker.Skolems import Language.PureScript.TypeChecker.Subsumption import Language.PureScript.TypeChecker.Synonyms+import Language.PureScript.TypeChecker.TypeSearch import Language.PureScript.TypeChecker.Unify import Language.PureScript.Types + data BindingGroupType   = RecursiveBindingGroup   | NonRecursiveBindingGroup@@ -70,13 +76,13 @@   -> [(Ident, Expr)]   -> m [(Ident, (Expr, Type))] typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do-    (tys, w) <- withoutWarnings . capturingSubstitution tidyUp $ do+    tys <- capturingSubstitution tidyUp $ do       (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup (Just moduleName) vals-      ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict-      ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict-      return (map (\x -> (False, x)) ds1 ++ map (\x -> (True, x)) ds2)+      ds1 <- parU typed $ \e -> withoutWarnings $ checkTypedBindingGroupElement moduleName e dict+      ds2 <- forM untyped $ \e -> withoutWarnings $ typeForBindingGroupElement e dict untypedDict+      return (map (False, ) ds1 ++ map (True, ) ds2) -    inferred <- forM tys $ \(shouldGeneralize, (ident, (val, ty))) -> do+    inferred <- forM tys $ \(shouldGeneralize, ((ident, (val, ty)), _)) -> do       -- Replace type class dictionary placeholders with actual dictionaries       (val', unsolved) <- replaceTypeClassDictionaries shouldGeneralize val       -- Generalize and constrain the type@@ -96,7 +102,7 @@           $ CannotGeneralizeRecursiveFunction ident generalized         -- Make sure any unsolved type constraints only use type variables which appear         -- unknown in the inferred type.-        forM_ unsolved $ \(_, con) -> do+        forM_ unsolved $ \(_, _, con) -> do           -- We need information about functional dependencies, since we allow           -- ambiguous types to be inferred if they can be solved by some functional           -- dependency.@@ -104,33 +110,56 @@           TypeClassData{ typeClassDependencies } <- gets (findClass . typeClasses . checkEnv)           let solved = foldMap (S.fromList . fdDetermined) typeClassDependencies           let constraintTypeVars = nub . foldMap (unknownsInType . fst) . filter ((`notElem` solved) . snd) $ zip (constraintArgs con) [0..]-          when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $-            throwError . onErrorMessages (replaceTypes currentSubst) . errorMessage $ NoInstanceFound con+          when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $ do+            throwError . onErrorMessages (replaceTypes currentSubst) . errorMessage $ AmbiguousTypeVariables generalized con        -- Check skolem variables did not escape their scope       skolemEscapeCheck val'       -- Check rows do not contain duplicate labels       checkDuplicateLabels val'-      return (ident, (foldr (Abs . Left . fst) val' unsolved, generalized))+      return ((ident, (foldr (Abs . Left . (\(x, _, _) -> x)) val' unsolved, generalized)), unsolved)      -- Show warnings here, since types in wildcards might have been solved during     -- instance resolution (by functional dependencies).-    finalSubst <- gets checkSubstitution-    escalateWarningWhen isHoleError . tell . onErrorMessages (replaceTypes finalSubst) $ w+    finalState <- get+    forM_ tys $ \(shouldGeneralize, ((_, (_, _)), w)) -> do+      let replaceTypes' = replaceTypes (checkSubstitution finalState)+          runTypeSearch' = runTypeSearch (guard shouldGeneralize $> foldMap snd inferred) finalState+      (escalateWarningWhen isHoleError . tell . onErrorMessages (runTypeSearch' . replaceTypes')) w -    return inferred+    return (map fst inferred)   where+    replaceTypes+      :: Substitution+      -> ErrorMessage+      -> ErrorMessage     replaceTypes subst = onTypesInErrorMessage (substituteType subst) +    -- | Run type search to complete any typed hole error messages+    runTypeSearch+      :: Maybe [(Ident, InstanceContext, Constraint)]+      -- ^ Any unsolved constraints which we need to continue to satisfy+      -> CheckState+      -- ^ The final type checker state+      -> ErrorMessage+      -> ErrorMessage+    runTypeSearch cons st = \case+      ErrorMessage hints (HoleInferredType x ty y (TSBefore env)) ->+        let subst = checkSubstitution st+            searchResult = (fmap . fmap) (substituteType subst)+                             (M.toList (typeSearch cons env st (substituteType subst ty)))+        in ErrorMessage hints (HoleInferredType x ty y (TSAfter searchResult))+      other -> other+     -- | Generalize type vars using forall and add inferred constraints     generalize unsolved = varIfUnknown . constrain unsolved      -- | Add any unsolved constraints     constrain [] = id-    constrain cs = ConstrainedType (map snd cs)+    constrain cs = ConstrainedType (map (\(_, _, x) -> x) cs)      -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values-    tidyUp ts sub = map (\(b, (i, (val, ty))) -> (b, (i, (overTypes (substituteType sub) val, substituteType sub ty)))) ts+    tidyUp ts sub = map (second (first (second (overTypes (substituteType sub) *** substituteType sub)))) ts      isHoleError :: ErrorMessage -> Bool     isHoleError (ErrorMessage _ HoleInferredType{}) = True@@ -199,19 +228,12 @@ -- | Check if a value contains a type annotation isTyped :: (Ident, Expr) -> Either (Ident, Expr) (Ident, (Expr, Type, Bool)) isTyped (name, TypedValue checkType value ty) = Right (name, (value, ty, checkType))+isTyped (name, PositionedValue pos c value) =+  bimap (second (PositionedValue pos c))+        (second (\(e, t, b) -> (PositionedValue pos c e, t, b)))+        (isTyped (name, value)) isTyped (name, value) = Left (name, value) --- |--- Map a function over type annotations appearing inside a value----overTypes :: (Type -> Type) -> Expr -> Expr-overTypes f = let (_, f', _) = everywhereOnValues id g id in f'-  where-  g :: Expr -> Expr-  g (TypedValue checkTy val t) = TypedValue checkTy val (f t)-  g (TypeClassDictionary c sco hints) = TypeClassDictionary (mapConstraintArgs (map f) c) sco hints-  g other = other- -- | Check the kind of a type, failing if it is not of kind *. checkTypeKind ::   (MonadError MultipleErrors m) =>@@ -339,7 +361,8 @@ infer' (Hole name) = do   ty <- freshType   ctx <- getLocalContext-  tell . errorMessage $ HoleInferredType name ty ctx+  env <- getEnv+  tell . errorMessage $ HoleInferredType name ty ctx (TSBefore env)   return $ TypedValue True (Hole name) ty infer' (PositionedValue pos c val) = warnAndRethrowWithPositionTC pos $ do   TypedValue t v ty <- infer' val@@ -568,18 +591,14 @@ check' (App f arg) ret = do   f'@(TypedValue _ _ ft) <- infer f   (retTy, app) <- checkFunctionApplication f' ft arg-  v' <- subsumes (Just app) retTy ret-  case v' of-    Nothing -> internalError "check: unable to check the subsumes relation."-    Just app' -> return $ TypedValue True app' ret+  elaborate <- subsumes retTy ret+  return $ TypedValue True (elaborate app) ret check' v@(Var var) ty = do   checkVisibility var   repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable $ var   ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty-  v' <- subsumes (Just v) repl ty'-  case v' of-    Nothing -> internalError "check: unable to check the subsumes relation."-    Just v'' -> return $ TypedValue True v'' ty'+  elaborate <- subsumes repl ty'+  return $ TypedValue True (elaborate v) ty' check' (DeferredDictionary className tys) _ = do   {-   -- Here, we replace a placeholder for a superclass dictionary with a regular@@ -596,12 +615,11 @@   checkTypeKind ty1 kind   ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty1   ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2-  val' <- subsumes (Just val) ty1' ty2'-  case val' of-    Nothing -> internalError "check: unable to check the subsumes relation."-    Just _ -> do-      val''' <- if checkType then withScopedTypeVars moduleName args (check val ty2') else return val-      return $ TypedValue checkType val''' ty2'+  _ <- subsumes ty1' ty2'+  val' <- if checkType+            then withScopedTypeVars moduleName args (check val ty2')+            else return val+  return $ TypedValue checkType val' ty2' check' (Case vals binders) ret = do   (vals', ts) <- instantiateForBinders vals binders   binders' <- checkBinders ts ret binders@@ -638,10 +656,8 @@     Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c     Just (_, _, ty1, _) -> do       repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1-      mv <- subsumes (Just v) repl ty-      case mv of-        Nothing -> internalError "check: unable to check the subsumes relation."-        Just v' -> return $ TypedValue True v' ty+      elaborate <- subsumes repl ty+      return $ TypedValue True (elaborate v) ty check' (Let ds val) ty = do   (ds', val') <- inferLetBinding [] ds val (`check` ty)   return $ TypedValue True (Let ds' val') ty@@ -654,10 +670,8 @@   return $ TypedValue t (PositionedValue pos c v) ty' check' val ty = do   TypedValue _ val' ty' <- infer val-  mt <- subsumes (Just val') ty' ty-  case mt of-    Nothing -> internalError "check: unable to check the subsumes relation."-    Just v' -> return $ TypedValue True v' ty+  elaborate <- subsumes ty' ty+  return $ TypedValue True (elaborate val') ty  -- | -- Check the type of a collection of named record fields
src/System/IO/UTF8.hs view
@@ -4,11 +4,21 @@  import qualified Data.ByteString as BS import qualified Data.ByteString.UTF8 as UTF8+import           Data.Text (Text)+import qualified Data.Text.Encoding as TE +readUTF8FileT :: FilePath -> IO Text+readUTF8FileT inFile =+  fmap TE.decodeUtf8 (BS.readFile inFile)++writeUTF8FileT :: FilePath -> Text -> IO ()+writeUTF8FileT inFile text =+  BS.writeFile inFile (TE.encodeUtf8 text)+ readUTF8File :: FilePath -> IO String-readUTF8File inFile = do+readUTF8File inFile =   fmap UTF8.toString (BS.readFile inFile)  writeUTF8File :: FilePath -> String -> IO ()-writeUTF8File inFile text = do+writeUTF8File inFile text =   BS.writeFile inFile (UTF8.fromString text)
stack.yaml view
@@ -1,12 +1,3 @@-resolver: lts-6.13+resolver: lts-6.10 packages: - '.'-extra-deps:-# - aeson-1.0.0.0-- http-client-0.5.1-- http-client-tls-0.3.0-- pipes-http-1.0.4-# - semigroups-0.18.2-# flags:-#   semigroups:-#     bytestring-builder: false
tests/Language/PureScript/Ide/FilterSpec.hs view
@@ -9,7 +9,7 @@ import           Test.Hspec  value :: Text -> IdeDeclarationAnn-value s = IdeDeclarationAnn emptyAnn (IdeValue (P.Ident (toS s)) P.REmpty)+value s = IdeDeclarationAnn emptyAnn (IdeDeclValue (IdeValue (P.Ident (toS s)) P.REmpty))  moduleA, moduleB :: Module moduleA = (P.moduleNameFromString "Module.A", [value "function1"])
tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs view
@@ -6,12 +6,12 @@ import           Protolude  import qualified Data.Text                           as T-import qualified Data.Text.IO                        as TIO import qualified Language.PureScript.Ide.Integration as Integration import           Test.Hspec  import           System.Directory import           System.FilePath+import           System.IO.UTF8                      (readUTF8FileT)  setup :: IO () setup = void (Integration.reset *> Integration.loadAll)@@ -27,7 +27,7 @@ outputFileShouldBe :: [Text] -> IO () outputFileShouldBe expectation = do   outFp <- (</> "src" </> "ImportsSpecOut.tmp") <$> Integration.projectDirectory-  outRes <- TIO.readFile outFp+  outRes <- readUTF8FileT outFp   shouldBe (T.lines outRes) expectation  spec :: Spec@@ -57,10 +57,10 @@     outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (class ATypeClass)"])   it "adds an explicit unqualified import (dataconstructor)" $ do     withSupportFiles (Integration.addImport "MyJust")-    outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyMaybe(MyJust))"])+    outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyMaybe(..))"])   it "adds an explicit unqualified import (newtype)" $ do     withSupportFiles (Integration.addImport "MyNewtype")-    outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyNewtype(MyNewtype))"])+    outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyNewtype(..))"])   it "adds an explicit unqualified import (typeclass member function)" $ do     withSupportFiles (Integration.addImport "typeClassFun")     outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (typeClassFun)"])
tests/Language/PureScript/Ide/ImportsSpec.hs view
@@ -68,11 +68,13 @@   describe "import commands" $ do     let simpleFileImports = let (_, _, i, _) = splitSimpleFile in i         addValueImport i mn is =-          prettyPrintImportSection (addExplicitImport' (IdeValue (P.Ident i) wildcard) mn is)+          prettyPrintImportSection (addExplicitImport' (IdeDeclValue (IdeValue (P.Ident i) wildcard)) mn is)         addOpImport op mn is =-          prettyPrintImportSection (addExplicitImport' (IdeValueOperator op (P.Qualified Nothing (Left (P.Ident ""))) 2 P.Infix Nothing) mn is)+          prettyPrintImportSection (addExplicitImport' (IdeDeclValueOperator (IdeValueOperator op (P.Qualified Nothing (Left (P.Ident ""))) 2 P.Infix Nothing)) mn is)         addDtorImport i t mn is =-          prettyPrintImportSection (addExplicitImport' (IdeDataConstructor (P.ProperName i) t wildcard) mn is)+          prettyPrintImportSection (addExplicitImport' (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName i) t wildcard)) mn is)+        addTypeImport i mn is =+          prettyPrintImportSection (addExplicitImport' (IdeDeclType (IdeType (P.ProperName i) P.Star)) mn is)     it "adds an implicit unqualified import" $       shouldBe         (addImplicitImport' simpleFileImports (P.moduleNameFromString "Data.Map"))@@ -100,20 +102,26 @@       shouldBe         (addOpImport (P.OpName "<~>") (P.moduleNameFromString "Data.Array") explicitImports)         [ "import Prelude"-        , "import Data.Array ((<~>), tail)"+        , "import Data.Array (tail, (<~>))"         ]+    it "adds a type with constructors without automatically adding an open import of said constructors " $+        shouldBe+          (addTypeImport "Maybe" (P.moduleNameFromString "Data.Maybe") simpleFileImports)+          [ "import Prelude"+          , "import Data.Maybe (Maybe)"+          ]     it "adds the type for a given DataConstructor" $         shouldBe           (addDtorImport "Just" (P.ProperName "Maybe") (P.moduleNameFromString "Data.Maybe") simpleFileImports)           [ "import Prelude"-          , "import Data.Maybe (Maybe(Just))"+          , "import Data.Maybe (Maybe(..))"           ]     it "adds a dataconstructor to an existing type import" $ do       let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe)"])       shouldBe         (addDtorImport "Just" (P.ProperName "Maybe") (P.moduleNameFromString "Data.Maybe") typeImports)         [ "import Prelude"-        , "import Data.Maybe (Maybe(Just))"+        , "import Data.Maybe (Maybe(..))"         ]     it "doesn't add a dataconstructor to an existing type import with open dtors" $ do       let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe(..))"])@@ -128,3 +136,38 @@       [ "import Prelude"       , "import Data.Array (tail)"       ]++  describe "explicit import sorting" $ do+    -- given some basic import skeleton+    let Right (_, _, baseImports, _) = sliceImportSection $ withImports ["import Control.Monad (ap)"]+        moduleName = (P.moduleNameFromString "Control.Monad")+        addImport imports import' = addExplicitImport' import' moduleName imports+        valueImport ident = (IdeDeclValue (IdeValue (P.Ident ident) wildcard))+        typeImport name = (IdeDeclType (IdeType (P.ProperName name) P.Star))+        classImport name = (IdeDeclTypeClass (P.ProperName name))+        dtorImport name typeName = (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName name) (P.ProperName typeName) wildcard))+        -- expect any list of provided identifiers, when imported, to come out as specified+        expectSorted imports expected = shouldBe+          (ordNub $ map+            (prettyPrintImportSection . foldl addImport baseImports)+            (permutations imports))+          [expected]+    it "sorts class" $+      expectSorted (map classImport ["Applicative", "Bind"])+        ["import Prelude", "import Control.Monad (class Applicative, class Bind, ap)"]+    it "sorts value" $+      expectSorted (map valueImport ["unless", "where"])+        ["import Prelude", "import Control.Monad (ap, unless, where)"]+    it "sorts type, value" $+      expectSorted+        ((map valueImport ["unless", "where"]) ++ (map typeImport ["Foo", "Bar"]))+        ["import Prelude", "import Control.Monad (Bar, Foo, ap, unless, where)"]+    it "sorts class, type, value" $+      expectSorted+        ((map valueImport ["unless", "where"]) ++ (map typeImport ["Foo", "Bar"]) ++ (map classImport ["Applicative", "Bind"]))+        ["import Prelude", "import Control.Monad (class Applicative, class Bind, Bar, Foo, ap, unless, where)"]+    it "sorts types with constructors, using open imports for the constructors" $+      expectSorted+        -- the imported names don't actually have to exist!+        (map (uncurry dtorImport) [("Just", "Maybe"), ("Nothing", "Maybe"), ("SomeOtherConstructor", "SomeDataType")])+        ["import Prelude", "import Control.Monad (Maybe(..), SomeDataType(..), ap)"]
tests/Language/PureScript/Ide/MatcherSpec.hs view
@@ -13,7 +13,7 @@ import           Test.Hspec  value :: Text -> IdeDeclarationAnn-value s = withEmptyAnn (IdeValue (P.Ident (toS s)) P.REmpty)+value s = withEmptyAnn (IdeDeclValue (IdeValue (P.Ident (toS s)) P.REmpty))  firstResult, secondResult, fiult :: Match IdeDeclarationAnn firstResult = Match (P.moduleNameFromString "Match", value "firstResult")
tests/Language/PureScript/Ide/ReexportsSpec.hs view
@@ -18,11 +18,11 @@ d = IdeDeclarationAnn emptyAnn  valueA, typeA, classA, dtorA1, dtorA2 :: IdeDeclarationAnn-valueA = d (IdeValue (P.Ident "valueA") P.REmpty)-typeA = d (IdeType (P.ProperName "TypeA") P.Star)-classA = d (IdeTypeClass (P.ProperName "ClassA"))-dtorA1 = d (IdeDataConstructor (P.ProperName "DtorA1") (P.ProperName "TypeA") P.REmpty)-dtorA2 = d (IdeDataConstructor (P.ProperName "DtorA2") (P.ProperName "TypeA") P.REmpty)+valueA = d (IdeDeclValue (IdeValue (P.Ident "valueA") P.REmpty))+typeA = d (IdeDeclType (IdeType(P.ProperName "TypeA") P.Star))+classA = d (IdeDeclTypeClass (P.ProperName "ClassA"))+dtorA1 = d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "DtorA1") (P.ProperName "TypeA") P.REmpty))+dtorA2 = d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "DtorA2") (P.ProperName "TypeA") P.REmpty))  env :: Map P.ModuleName [IdeDeclarationAnn] env = Map.fromList
tests/Language/PureScript/Ide/StateSpec.hs view
@@ -11,20 +11,20 @@  valueOperator :: Maybe P.Type -> IdeDeclarationAnn valueOperator =-  d . IdeValueOperator (P.OpName "<$>") (P.Qualified (Just (mn "Test")) (Left (P.Ident "function"))) 2 P.Infix+  d . IdeDeclValueOperator . IdeValueOperator (P.OpName "<$>") (P.Qualified (Just (mn "Test")) (Left (P.Ident "function"))) 2 P.Infix  ctorOperator :: Maybe P.Type -> IdeDeclarationAnn ctorOperator =-  d . IdeValueOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (Right (P.ProperName "Cons"))) 2 P.Infix+  d . IdeDeclValueOperator . IdeValueOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (Right (P.ProperName "Cons"))) 2 P.Infix  typeOperator :: Maybe P.Kind -> IdeDeclarationAnn typeOperator =-  d . IdeTypeOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (P.ProperName "List")) 2 P.Infix+  d . IdeDeclTypeOperator . IdeTypeOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (P.ProperName "List")) 2 P.Infix  testModule :: Module-testModule = (mn "Test", [ d (IdeValue (P.Ident "function") P.REmpty)-                         , d (IdeDataConstructor (P.ProperName "Cons") (P.ProperName "List") (P.REmpty))-                         , d (IdeType (P.ProperName "List") P.Star)+testModule = (mn "Test", [ d (IdeDeclValue (IdeValue (P.Ident "function") P.REmpty))+                         , d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "Cons") (P.ProperName "List") (P.REmpty)))+                         , d (IdeDeclType (IdeType (P.ProperName "List") P.Star))                          , valueOperator Nothing                          , ctorOperator Nothing                          , typeOperator Nothing
tests/TestCompiler.hs view
@@ -31,6 +31,7 @@ import Data.Maybe (mapMaybe) import Data.Time.Clock (UTCTime()) import Data.Tuple (swap)+import qualified Data.Text as T  import qualified Data.Map as M @@ -71,7 +72,7 @@     supportPurs <- supportFiles "purs"     supportPursFiles <- readInput supportPurs     supportExterns <- runExceptT $ do-      modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles+      modules <- ExceptT . return $ P.parseModulesFromFiles id (map (fmap T.pack) supportPursFiles)       foreigns <- inferForeignModules modules       externs <- ExceptT . fmap fst . runTest $ P.make (makeActions foreigns) (map snd modules)       return (zip (map snd modules) externs)@@ -194,7 +195,7 @@   -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors) compile supportExterns inputFiles check = silence $ runTest $ do   fs <- liftIO $ readInput inputFiles-  ms <- P.parseModulesFromFiles id fs+  ms <- P.parseModulesFromFiles id (map (fmap T.pack) fs)   foreigns <- inferForeignModules ms   liftIO (check (map snd ms))   let actions = makeActions foreigns
tests/TestUtils.hs view
@@ -53,16 +53,24 @@ -- supportModules :: [String] supportModules =-  [ "Control.Applicative"+  [ "Control.Alt"+  , "Control.Alternative"+  , "Control.Applicative"   , "Control.Apply"   , "Control.Bind"   , "Control.Category"+  , "Control.Comonad"+  , "Control.Extend"+  , "Control.Lazy"+  , "Control.Monad"+  , "Control.Monad.Eff"   , "Control.Monad.Eff.Class"   , "Control.Monad.Eff.Console"   , "Control.Monad.Eff.Unsafe"-  , "Control.Monad.Eff"   , "Control.Monad.ST"-  , "Control.Monad"+  , "Control.MonadPlus"+  , "Control.MonadZero"+  , "Control.Plus"   , "Control.Semigroupoid"   , "Data.Boolean"   , "Data.BooleanAlgebra"@@ -71,14 +79,27 @@   , "Data.Eq"   , "Data.EuclideanRing"   , "Data.Field"-  , "Data.Function.Uncurried"   , "Data.Function"+  , "Data.Function.Uncurried"   , "Data.Functor"+  , "Data.Functor.Invariant"+  , "Data.Generic.Rep"+  , "Data.Generic.Rep.Monoid"+  , "Data.Generic.Rep.Eq"+  , "Data.Generic.Rep.Ord"+  , "Data.Generic.Rep.Semigroup"   , "Data.HeytingAlgebra"+  , "Data.Monoid"+  , "Data.Monoid.Additive"+  , "Data.Monoid.Conj"+  , "Data.Monoid.Disj"+  , "Data.Monoid.Dual"+  , "Data.Monoid.Endo"+  , "Data.Monoid.Multiplicative"   , "Data.NaturalTransformation"   , "Data.Newtype"-  , "Data.Ord.Unsafe"   , "Data.Ord"+  , "Data.Ord.Unsafe"   , "Data.Ordering"   , "Data.Ring"   , "Data.Semigroup"@@ -90,6 +111,7 @@   , "Partial.Unsafe"   , "Prelude"   , "Test.Assert"+  , "Test.Main"   ]  pushd :: forall a. FilePath -> IO a -> IO a
tests/support/bower.json view
@@ -8,6 +8,7 @@     "purescript-prelude": "1.1.0",     "purescript-st": "1.0.0-rc.1",     "purescript-partial": "1.1.2",-    "purescript-newtype": "0.1.0"+    "purescript-newtype": "0.1.0",+    "purescript-generics-rep": "2.0.0"   } }