packages feed

purescript 0.7.6.1 → 0.8.0.0

raw patch · 146 files changed

+5425/−2678 lines, 146 filesdep ~aesondep ~aeson-better-errorsdep ~base-compat

Dependency ranges changed: aeson, aeson-better-errors, base-compat, transformers, transformers-compat

Files

CONTRIBUTORS.md view
@@ -12,6 +12,7 @@ - [@balajirrao](https://github.com/balajirrao) (Balaji Rao) - My existing contributions and all future contributions until further notice are Copyright Balaji Rao, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@bergmark](https://github.com/bergmark) (Adam Bergmark) - My existing contributions and all future contributions until further notice are Copyright Adam Bergmark, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@Bogdanp](https://github.com/Bogdanp) (Bogdan Paul Popa) My existing contributions and all future contributions until further notice are Copyright Bogdan Paul Popa, 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).+- [@cdepillabout](https://github.com/cdepillabout) (Dennis Gosnell) My existing contributions and all future contributions until further notice are Copyright Dennis Gosnell, 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). - [@davidchambers](https://github.com/davidchambers) (David Chambers) My existing contributions and all future contributions until further notice are Copyright David Chambers, 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). - [@dckc](https://github.com/dckc) (Dan Connolly) My existing contributions and all future contributions until further notice are Copyright Dan Connolly, 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). - [@dylex](https://github.com/dylex) (Dylan Simon) My existing and all future contributions to the PureScript compiler until further notice are Copyright Dylan Simon, 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).@@ -26,7 +27,9 @@ - [@joneshf](https://github.com/joneshf) (Hardy Jones) - My existing contributions and all future contributions until further notice are Copyright Hardy Jones, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@kRITZCREEK](https://github.com/kRITZCREEK) (Christoph Hegemann) - My existing contributions and all future contributions until further notice are Copyright Christoph Hegemann, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@L8D](https://github.com/L8D) (Tenor Biel) My existing contributions and all future contributions until further notice are Copyright Tenor Biel, 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).+- [@leighman](http://github.com/leighman) (Jack Leigh) My existing contributions and all future contributions until further notice are Copyright Jack Leigh, 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). - [@lukerandall](https://github.com/lukerandall) (Luke Randall) My existing contributions and all future contributions until further notice are Copyright Luke Randall, 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).+- [@mgmeier](https://github.com/mgmeier) (Michael Karg) My existing contributions and all future contributions until further notice are Copyright Michael Gilliland, 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). - [@michaelficarra](https://github.com/michaelficarra) (Michael Ficarra) My existing contributions and all future contributions until further notice are Copyright Michael Ficarra, 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). - [@MichaelXavier](https://github.com/MichaelXavier) (Michael Xavier) - My existing contributions and all future contributions until further notice are Copyright Michael Xavier, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@mjgpy3](https://github.com/mjgpy3) (Michael Gilliland) My existing contributions and all future contributions until further notice are Copyright Michael Gilliland, 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).@@ -48,6 +51,7 @@ - [@robdaemon](https://github.com/robdaemon) (Robert Roland) My existing contributions and all future contributions until further notice are Copyright Robert Roland, 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). - [@RossMeikleham](https://github.com/RossMeikleham) (Ross Meikleham) My existing contributions and all future contributions until further notice are Copyright Ross Meikleham, 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). - [@sebastiaanvisser](https://github.com/sebastiaanvisser) (Sebastiaan Visser) - My existing contributions and all future contributions until further notice are Copyright Sebastiaan Visser, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.+- [@sharkdp](https://github.com/sharkdp) (David Peter) My existing contributions and all future contributions until further notice are Copyright David Peter, 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). - [@sztupi](https://github.com/sztupi) (Attila Sztupak) My existing contributions and all future contributions until further notice are Copyright Attila Sztupak, 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). - [@taku0](https://github.com/taku0) - My existing contributions and all future contributions until further notice are Copyright taku0, 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). - [@trofi](https://github.com/trofi) (Sergei Trofimovich) My existing contributions and all future contributions until further notice are Copyright Sergei Trofimovich, 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).@@ -58,6 +62,9 @@ <http://opensource.org/licenses/MIT>. - [@soupi](https://github.com/soupi) (Gil Mizrahi) My existing contributions and all future contributions until further notice are Copyright Gil Mizrahi, 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). - [@tfausak](https://github.com/tfausak) (Taylor Fausak) My existing contributions and all future contributions until further notice are Copyright Taylor Fausak, 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).+- [@codedmart](https://github.com/codedmart) (Brandon Martin) My existing contributions and all future contributions until further notice are Copyright Brandon Martin, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).+- [@passy](https://github.com/passy) (Pascal Hartig) My existing contributions and all future contributions until further notice are Copyright Pascal Hartig, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).+- [@DavidLindbom](https://github.com/DavidLindbom) (David Lindbom) My existing contributions and all future contributions until further notice are Copyright David Lindbom, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).  ### Companies
INSTALL.md view
@@ -27,7 +27,7 @@ use stack:  ```-$ stack install purescript+$ stack install --resolver lts purescript ```  This will then copy the compiler and utilities into `~/.local/bin`.
+ examples/docs/bower.json view
@@ -0,0 +1,19 @@+{+  "name": "docs-test-package",+  "version": "1.0.0",+  "moduleType": [+    "node"+  ],+  "repository": {+    "type": "git",+    "url": "git://github.com/not-real/not-a-real-repo.git"+  },+  "ignore": [+    "**/.*",+    "node_modules",+    "bower_components",+    "output"+  ],+  "dependencies": {+  }+}
+ examples/docs/bower_components/purescript-prelude/src/Prelude.purs view
@@ -0,0 +1,8 @@+module Prelude where++newtype Unit = Unit {}++unit :: Unit+unit = Unit {}++data Boolean2 = True | False
+ examples/docs/src/Clash.purs view
@@ -0,0 +1,32 @@+module Clash (module Clash1) where++import Clash1 as Clash1+import Clash2 as Clash2++module Clash1 (module Clash1a) where++import Clash1a++module Clash1a where++value :: Int+value = 0++type Type = Int++class TypeClass a where+  typeClassMember :: a++module Clash2 (module Clash2a) where++import Clash2a++module Clash2a where++value :: String+value = "hello"++type Type = String++class TypeClass a b where+  typeClassMember :: a -> b
+ examples/docs/src/DuplicateNames.purs view
@@ -0,0 +1,9 @@+module DuplicateNames+  ( module DuplicateNames+  , module Prelude+  ) where++import Prelude (Unit)++unit :: Int+unit = 0
+ examples/docs/src/Example.purs view
@@ -0,0 +1,7 @@+module Example+  ( module Prelude+  , module Example2+  ) where++import Prelude (Unit())+import Example2 (one)
+ examples/docs/src/Example2.purs view
@@ -0,0 +1,7 @@+module Example2 where++one :: Int+one = 1++two :: Int+two = 2
+ examples/docs/src/ImportedTwice.purs view
@@ -0,0 +1,27 @@+-- See also an example in the wild: purescript-transformers v0.8.4.+-- Control.Monad.RWS.Trans re-exports `lift` from both Control.Monad.Trans+-- (where it is originally defined) and Control.Monad.RWS.Class (which+-- re-exports it from Control.Monad.Trans).++module ImportedTwice+  ( module A+  , module B+  )+  where++import A+import B++module A+  ( module B )+  where++import B++bar :: Int+bar = 1++module B where++foo :: Int+foo = 0
+ examples/docs/src/MultiVirtual.purs view
@@ -0,0 +1,27 @@+module MultiVirtual+  ( module X )+  where++import MultiVirtual1 as X+import MultiVirtual2 as X+++module MultiVirtual1 where++foo :: Int+foo = 1++module MultiVirtual2 +  ( module MultiVirtual2+  , module MultiVirtual3+  ) where++import MultiVirtual3++bar :: Int+bar = 2++module MultiVirtual3 where++baz :: Int+baz = 3
+ examples/docs/src/NewOperators.purs view
@@ -0,0 +1,12 @@+module NewOperators+  ( module NewOperators2 )+  where++import NewOperators2++module NewOperators2 where++infixl 8 _compose as >>>++_compose :: forall a b c. (b -> c) -> (a -> b) -> (a -> c)+_compose f g x = f (g x)
+ examples/docs/src/NotAllCtors.purs view
@@ -0,0 +1,5 @@+module NotAllCtors+  ( module Prelude )+  where++import Prelude (Boolean2(True))
+ examples/docs/src/OldOperators.purs view
@@ -0,0 +1,10 @@++-- Remove this after 0.9.+module OldOperators (module OldOperators2) where++import OldOperators2++module OldOperators2 where++(>>) :: forall a. a -> a -> a+(>>) a b = b
+ examples/docs/src/ReExportedTypeClass.purs view
@@ -0,0 +1,5 @@+module ReExportedTypeClass+  ( module SomeTypeClass )+  where++import SomeTypeClass
+ examples/docs/src/SolitaryTypeClassMember.purs view
@@ -0,0 +1,6 @@+module SolitaryTypeClassMember+  ( module SomeTypeClass )+  where++import SomeTypeClass (member)+
+ examples/docs/src/SomeTypeClass.purs view
@@ -0,0 +1,5 @@++module SomeTypeClass where++class SomeClass a where+  member :: a
+ examples/docs/src/Transitive1.purs view
@@ -0,0 +1,5 @@+module Transitive1+  ( module Transitive2 )+  where++import Transitive2
+ examples/docs/src/Transitive2.purs view
@@ -0,0 +1,5 @@+module Transitive2+  ( module Transitive3 )+  where++import Transitive3
+ examples/docs/src/Transitive3.purs view
@@ -0,0 +1,4 @@+module Transitive3 where++transitive3 :: Int+transitive3 = 0
+ examples/docs/src/TypeClassWithoutMembers.purs view
@@ -0,0 +1,11 @@+module TypeClassWithoutMembers+  ( module Intermediate )+  where++import Intermediate++module Intermediate+  ( module SomeTypeClass )+  where++import SomeTypeClass (SomeClass)
+ examples/docs/src/UTF8.purs view
@@ -0,0 +1,7 @@+module UTF8 where++import Prelude (Unit, unit)++-- | üÜäÄ 😰+thing :: Unit+thing = unit
+ examples/docs/src/Virtual.purs view
@@ -0,0 +1,5 @@+module Virtual+  ( module VirtualPrelude )+  where++import Prelude as VirtualPrelude
+ examples/failing/1733.purs view
@@ -0,0 +1,13 @@+-- @shouldFailWith UnknownValue++module Main where++import Thingy as Thing++main = Thing.doesntExist "hi"++module Thingy where++foo :: Int+foo = 1+
+ examples/failing/1825.purs view
@@ -0,0 +1,9 @@+-- @shouldFailWith UnknownValue++module Main where++data W = X | Y | Z++bad X a = a +bad Y _ = a +bad Z a = a
+ examples/failing/CaseBinderLengthsDiffer.purs view
@@ -0,0 +1,6 @@+-- @shouldFailWith CaseBinderLengthDiffers+module Main where++test = case 1, 2 of+  1, 2, 3 -> 42+  _, _    -> 43
+ examples/failing/ConflictingExports.purs view
@@ -0,0 +1,16 @@+-- @shouldFailWith ScopeConflict+module A where++  thing :: Int+  thing = 1++module B where++  thing :: Int+  thing = 2++-- Fails here because re-exporting forces any scope conflicts to be resolved+module Main (module A, module B) where++  import A+  import B
+ examples/failing/ConflictingExports2.purs view
@@ -0,0 +1,13 @@+-- @shouldFailWith ScopeConflict+module A where++  thing :: Int+  thing = 1++-- Fails here because re-exporting forces any scope conflicts to be resolved+module Main (thing, module A) where++  import A++  thing :: Int+  thing = 2
+ examples/failing/ConflictingImports.purs view
@@ -0,0 +1,19 @@+-- @shouldFailWith ScopeConflict+module A where++  thing :: Int+  thing = 1++module B where++  thing :: Int+  thing = 2++module Main where++  import A+  import B++  -- Error due to referencing `thing` which is in scope as A.thing and B.thing+  what :: Int+  what = thing
+ examples/failing/ConflictingImports2.purs view
@@ -0,0 +1,16 @@+-- @shouldFailWith ScopeConflict+module A where++  thing :: Int+  thing = 1++module Main where++  import A++  thing :: Int+  thing = 2++  -- Error due to referencing `thing` which is in scope as A.thing and Main.thing+  what :: Int+  what = thing
+ examples/failing/ConflictingQualifiedImports.purs view
@@ -0,0 +1,17 @@+-- @shouldFailWith ScopeConflict+module A where++  thing :: Int+  thing = 1++module B where++  thing :: Int+  thing = 2++module Main where++  import A as X+  import B as X++  foo = X.thing
+ examples/failing/ConflictingQualifiedImports2.purs view
@@ -0,0 +1,15 @@+-- @shouldFailWith ScopeConflict+module A where++  thing :: Int+  thing = 1++module B where++  thing :: Int+  thing = 2++module Main (module X) where++  import A as X+  import B as X
+ examples/failing/IntOutOfRange.purs view
@@ -0,0 +1,6 @@+-- @shouldFailWith IntOutOfRange++module Main where++n :: Int+n = 2147483648
+ examples/failing/OperatorAliasNoExport.purs view
@@ -0,0 +1,7 @@+-- @shouldFailWith TransitiveExportError+module Test ((?!)) where++infixl 4 what as ?!++what :: forall a b. a -> b -> a+what a _ = a
+ examples/passing/1185.purs view
@@ -0,0 +1,13 @@+module Main where++data Person = Person String Boolean++getName :: Person -> String+getName p = case p of+              Person name true -> name+              _ -> "Unknown"++name :: String+name = getName (Person "John Smith" true)++main = Control.Monad.Eff.Console.log "Done"
+ examples/passing/1664.purs view
@@ -0,0 +1,16 @@+module Main where++import Prelude+import Control.Monad.Eff+import Control.Monad.Eff.Console++data Identity a = Identity a++newtype IdentityEff e a = IdentityEff (Eff e (Identity a))++test :: forall e a. IdentityEff e a -> IdentityEff e Unit+test (IdentityEff action) = IdentityEff $ do+  (Identity x :: Identity _) <- action+  return $ Identity unit++main = log "Done"
+ examples/passing/1697.purs view
@@ -0,0 +1,24 @@+module Main where++import Prelude++_2 :: forall a. a -> a+_2 a = a++x :: forall m. (Monad m) => m Unit+x = do+  _ <- pure unit+  pure unit++y :: forall m. (Monad m) => m Unit+y = do+  _ <- pure unit+  pure unit++wtf :: forall m. (Monad m) => m Unit+wtf = do+  _ <- pure unit+  let tmp = _2 1+  pure unit++main = Control.Monad.Eff.Console.log "Done"
+ examples/passing/CaseMultipleExpressions.purs view
@@ -0,0 +1,19 @@+module Main where++import Prelude+import Control.Monad.Eff.Console+import Control.Monad.Eff++doIt :: forall eff. Eff eff Boolean+doIt = return true++set = do+  log "Testing..."+  case 42, 10 of+    42, 10 -> doIt+    _ , _  -> return false++main = do+  b <- set+  case b of+    true -> log "Done"
+ examples/passing/ClassRefSyntax.purs view
@@ -0,0 +1,13 @@+module Lib (class X, go) where++  class X a where+    go :: a -> a++module Main where++  import Lib (class X, go)++  go' :: forall a. (X a) => a -> a+  go' = go++  main = Control.Monad.Eff.Console.log "Done"
examples/passing/EmptyTypeClass.purs view
@@ -2,11 +2,11 @@  import Prelude -class Partial+class PartialP -head :: forall a. (Partial) => Array a -> a+head :: forall a. (PartialP) => Array a -> a head [x] = x -instance allowPartials :: Partial+instance allowPartials :: PartialP  main = Control.Monad.Eff.Console.log $ head ["Done"]
examples/passing/NakedConstraint.purs view
@@ -2,8 +2,6 @@  import Control.Monad.Eff.Console -class Partial - data List a = Nil | Cons a (List a)  head :: (Partial) => List Int -> Int
+ examples/passing/NegativeIntInRange.purs view
@@ -0,0 +1,8 @@+module Main where++import Prelude++n :: Int+n = -2147483648++main = Control.Monad.Eff.Console.log "Done"
+ examples/passing/NonConflictingExports.purs view
@@ -0,0 +1,14 @@+module A where++  thing :: Int+  thing = 1++-- No failure here as the export `thing` only refers to Main.thing+module Main (thing, main) where++  import A++  thing :: Int+  thing = 2++  main = Control.Monad.Eff.Console.log "Done"
+ examples/passing/OperatorAlias.purs view
@@ -0,0 +1,11 @@+module Main where++import Prelude+import Control.Monad.Eff.Console++infixl 4 what as ?!++what :: forall a b. a -> b -> a+what a _ = a++main = log $ "Done" ?! true
+ examples/passing/OperatorAliasElsewhere.purs view
@@ -0,0 +1,14 @@+module Def where++what :: forall a b. a -> b -> a+what a _ = a++module Main where++import Prelude+import Def (what)+import Control.Monad.Eff.Console++infixl 4 what as ?!++main = log $ "Done" ?! true
+ examples/passing/PendingConflictingImports.purs view
@@ -0,0 +1,17 @@+module A where++  thing :: Int+  thing = 1++module B where++  thing :: Int+  thing = 2++module Main where++  -- No error as we never force `thing` to be resolved in `Main`+  import A+  import B++  main = Control.Monad.Eff.Console.log "Done"
+ examples/passing/PendingConflictingImports2.purs view
@@ -0,0 +1,14 @@+module A where++  thing :: Int+  thing = 1++module Main where++  import A++  -- No error as we never force `thing` to be resolved in `Main`+  thing :: Int+  thing = 2++  main = Control.Monad.Eff.Console.log "Done"
+ examples/passing/ShadowedModuleName.purs view
@@ -0,0 +1,15 @@+module Test where++  data Z = Z String++  runZ :: Z -> String+  runZ (Z s) = s++module Main where++  import Test+  import Control.Monad.Eff.Console++  data Test = Test++  main = log (runZ (Z "done"))
+ examples/passing/TCO.purs view
@@ -0,0 +1,20 @@+module Main where++import Prelude+import Control.Monad.Eff.Console (print)++main = do+  let f x = x + 1+  let v = 0+  print (applyN 0 f v)+  print (applyN 1 f v)+  print (applyN 2 f v)+  print (applyN 3 f v)+  print (applyN 4 f v)++applyN :: forall a. Int -> (a -> a) -> a -> a+applyN = go id+  where+  go f n _ | n <= 0 = f+  go f n g = go (f >>> g) (n - 1) g+
+ examples/passing/TypeWithoutParens.purs view
@@ -0,0 +1,16 @@+module Lib (X, Y) where++  data X = X+  type Y = X++module Main where++  import Lib (X, Y)++  idX :: X -> X+  idX x = x++  idY :: Y -> Y+  idY y = y++  main = Control.Monad.Eff.Console.log "Done"
+ examples/passing/UnicodeIdentifier.purs view
@@ -0,0 +1,5 @@+module Main where++f asgård = asgård++main = Control.Monad.Eff.Console.log (f "Done")
+ examples/passing/UnicodeOperators.purs view
@@ -0,0 +1,20 @@+module Main where++compose :: forall a b c. (b -> c) -> (a -> b) -> a -> c+compose f g a = f (g a)++infixr 9 compose as ∘++test1 = (\x -> x) ∘ \y -> y++elem :: forall a b. a -> (a -> Boolean) -> Boolean+elem x f = f x++infixl 1 elem as ∈++emptySet :: forall a. a -> Boolean+emptySet _ = true++test2 = 1 ∈ emptySet++main = Control.Monad.Eff.Console.log "Done"
+ examples/passing/UnicodeType.purs view
@@ -0,0 +1,23 @@+module Main where++import Prelude++class (Monad m) ⇐ Monad1 m where+  f1 :: Int++class (Monad m) <= Monad2 m where+  f2 :: Int++f ∷ ∀ m. Monad m ⇒ Int → m Int+f n = do+  n' ← return n+  return n'++f' :: forall m. Monad m => Int -> m Int+f' n = do+  n' <- return n+  return n'++(←→) a b = a ←→ b++main = Control.Monad.Eff.Console.log "Done"
+ examples/passing/UntupledConstraints.purs view
@@ -0,0 +1,17 @@+module Main where++import Prelude+import Control.Monad.Eff.Console++class Show a <= Nonsense a where+  method :: a -> a++data Box a = Box a++instance showBox :: Show a => Show (Box a) where+  show (Box a) = "Box " <> show a++strangeThing :: forall m. Semigroup (m Unit) => m Unit -> m Unit -> m Unit+strangeThing x y = x <> y++main = log "Done"
hierarchy/Main.hs view
@@ -14,6 +14,7 @@ -----------------------------------------------------------------------------  {-# LANGUAGE TupleSections #-}+{-# LANGUAGE DataKinds #-}  module Main where @@ -38,7 +39,7 @@   , hierarchyOutput :: Maybe FilePath   } -newtype SuperMap = SuperMap { unSuperMap :: Either P.ProperName (P.ProperName, P.ProperName) }+newtype SuperMap = SuperMap { unSuperMap :: Either (P.ProperName 'P.ClassName) ((P.ProperName 'P.ClassName), (P.ProperName 'P.ClassName)) }   deriving Eq  instance Show SuperMap where
psc-bundle/Main.hs view
@@ -70,7 +70,7 @@   input <- for inputFiles $ \filename -> do     js <- liftIO (readFile filename)     mid <- guessModuleIdentifier filename-    return (mid, js)+    length js `seq` return (mid, js)                                            -- evaluate readFile till EOF before returning, not to exhaust file handles    let entryIds = map (`ModuleIdentifier` Regular) optionsEntryPoints
psc-docs/Main.hs view
@@ -16,6 +16,7 @@ module Main where  import Control.Applicative+import Control.Monad.Trans.Except (runExceptT) import Control.Arrow (first, second) import Control.Category ((>>>)) import Control.Monad.Writer@@ -68,61 +69,68 @@     Etags -> dumpTags input dumpEtags     Ctags -> dumpTags input dumpCtags     Markdown -> do-      e <- D.parseAndDesugar input [] (\_ ms -> return ms)-      case e of-        Left (D.ParseError err) -> do-          hPutStrLn stderr $ show err-          exitFailure-        Left (D.SortModulesError err) -> do-          hPutStrLn stderr $ P.prettyPrintMultipleErrors False err-          exitFailure-        Left (D.DesugarError err) -> do-          hPutStrLn stderr $ P.prettyPrintMultipleErrors False err-          exitFailure-        Right ms' ->-          case output of-            EverythingToStdOut ->-              putStrLn (D.renderModulesAsMarkdown ms')-            ToStdOut names -> do-              let (ms, missing) = takeModulesByName ms' names-              guardMissing missing-              putStrLn (D.renderModulesAsMarkdown ms)-            ToFiles names -> do-              let (ms, missing) = takeModulesByName' ms' names-              guardMissing missing-              let ms'' = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ map swap ms-              forM_ ms'' $ \grp -> do-                let fp = fst (head grp)-                createDirectoryIfMissing True (takeDirectory fp)-                writeFile fp (D.renderModulesAsMarkdown $ snd `map` grp)+      ms <- runExceptT (D.parseAndDesugar input []+                           >>= ((\(ms, _, env) -> D.convertModulesInPackage env ms)))+               >>= successOrExit++      case output of+        EverythingToStdOut ->+          putStrLn (D.runDocs (D.modulesAsMarkdown ms))+        ToStdOut names -> do+          let (ms', missing) = takeByName ms (map P.runModuleName names)+          guardMissing missing+          putStrLn (D.runDocs (D.modulesAsMarkdown ms'))+        ToFiles names -> do+          let (ms', missing) = takeByName' ms (map (first P.runModuleName) names)+          guardMissing missing++          let ms'' = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ map swap ms'+          forM_ ms'' $ \grp -> do+            let fp = fst (head grp)+            createDirectoryIfMissing True (takeDirectory fp)+            writeFile fp (D.runDocs (D.modulesAsMarkdown (map snd grp)))+   where   guardMissing [] = return ()   guardMissing [mn] = do-    hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ show mn ++ "\"")+    hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ mn ++ "\"")     exitFailure   guardMissing mns = do     hPutStrLn stderr "psc-docs: error: unknown modules:"     forM_ mns $ \mn ->-      hPutStrLn stderr ("  * " ++ show mn)+      hPutStrLn stderr ("  * " ++ mn)     exitFailure +  successOrExit :: Either P.MultipleErrors a -> IO a+  successOrExit act =+    case act of+      Right x ->+        return x+      Left err -> do+        hPutStrLn stderr $ P.prettyPrintMultipleErrors False err+        exitFailure++  takeByName = takeModulesByName D.modName+  takeByName' = takeModulesByName' D.modName+ -- | -- Given a list of module names and a list of modules, return a list of modules -- whose names appeared in the given name list, together with a list of names -- for which no module could be found in the module list. ---takeModulesByName :: [P.Module] -> [P.ModuleName] -> ([P.Module], [P.ModuleName])-takeModulesByName modules names =-  first (map fst) (takeModulesByName' modules (map (,()) names))+takeModulesByName :: (Eq n) => (m -> n) -> [m] -> [n] -> ([m], [n])+takeModulesByName getModuleName modules names =+  first (map fst) (takeModulesByName' getModuleName modules (map (,()) names))  -- |--- Like takeModulesByName but also keeps some extra data with the module.+-- Like takeModulesByName, but also keeps some extra information with each+-- module. ---takeModulesByName' :: [P.Module] -> [(P.ModuleName, a)] -> ([(P.Module, a)], [P.ModuleName])-takeModulesByName' modules = foldl go ([], [])+takeModulesByName' :: (Eq n) => (m -> n) -> [m] -> [(n, a)] -> ([(m, a)], [n])+takeModulesByName' getModuleName modules = foldl go ([], [])   where   go (ms, missing) (name, x) =-    case find ((== name) . P.getModuleName) modules of+    case find ((== name) . getModuleName) modules of       Just m  -> ((m, x) : ms, missing)       Nothing -> (ms, name : missing) @@ -236,16 +244,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\" \"bower_components/*/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\" \"bower_components/*/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\" \"bower_components/*/src/**/*.purs\" \\"     , "      --docgen Data.List:docs/Data.List.md \\"     , "      --docgen Data.List.Lazy:docs/Data.List.Lazy.md"     ]
psc-docs/Tags.hs view
@@ -10,9 +10,9 @@         dtags _ = []         names (P.DataDeclaration _ name _ dcons) = P.runProperName name : consNames           where consNames = map (\(cname, _) -> P.runProperName cname) dcons-        names (P.TypeDeclaration ident _) = [show ident]-        names (P.ExternDeclaration ident _) = [show ident]+        names (P.TypeDeclaration ident _) = [P.showIdent ident]+        names (P.ExternDeclaration ident _) = [P.showIdent ident]         names (P.TypeSynonymDeclaration name _ _) = [P.runProperName name]         names (P.TypeClassDeclaration name _ _ _) = [P.runProperName name]-        names (P.TypeInstanceDeclaration name _ _ _ _) = [show name]+        names (P.TypeInstanceDeclaration name _ _ _ _) = [P.showIdent name]         names _ = []
+ psc/JSON.hs view
@@ -0,0 +1,80 @@+-----------------------------------------------------------------------------+--+-- Module      :  Main+-- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess+-- License     :  MIT (http://opensource.org/licenses/MIT)+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++{-# LANGUAGE TemplateHaskell #-}++module JSON where++import Prelude ()+import Prelude.Compat++import qualified Data.Aeson.TH as A++import qualified Language.PureScript as P++data ErrorPosition = ErrorPosition+  { startLine :: Int+  , startColumn :: Int+  , endLine :: Int+  , endColumn :: Int+  }++data ErrorSuggestion = ErrorSuggestion { replacement :: String }++data JSONError = JSONError+  { position :: Maybe ErrorPosition+  , message :: String+  , errorCode :: String+  , errorLink :: String+  , filename :: Maybe String+  , moduleName :: Maybe String+  , suggestion :: Maybe ErrorSuggestion+  }++data JSONResult = JSONResult+  { warnings :: [JSONError]+  , errors :: [JSONError]+  }++$(A.deriveJSON A.defaultOptions ''ErrorPosition)+$(A.deriveJSON A.defaultOptions ''JSONError)+$(A.deriveJSON A.defaultOptions ''JSONResult)+$(A.deriveJSON A.defaultOptions ''ErrorSuggestion)+++toJSONErrors :: Bool -> P.Level -> P.MultipleErrors -> [JSONError]+toJSONErrors verbose level = map (toJSONError verbose level) . P.runMultipleErrors++toJSONError :: Bool -> P.Level -> P.ErrorMessage -> JSONError+toJSONError verbose level e =+  JSONError (toErrorPosition <$> sspan)+            (P.renderBox (P.prettyPrintSingleError verbose level False (P.stripModuleAndSpan e)))+            (P.errorCode e)+            (P.wikiUri e)+            (P.spanName <$> sspan)+            (P.runModuleName <$> P.errorModule e)+            (toSuggestion <$> (P.errorSuggestion $ P.unwrapErrorMessage e))+  where+  sspan :: Maybe P.SourceSpan+  sspan = P.errorSpan e++  toErrorPosition :: P.SourceSpan -> ErrorPosition+  toErrorPosition ss =+    ErrorPosition (P.sourcePosLine   (P.spanStart ss))+                  (P.sourcePosColumn (P.spanStart ss))+                  (P.sourcePosLine   (P.spanEnd   ss))+                  (P.sourcePosColumn (P.spanEnd   ss))+  toSuggestion :: P.ErrorSuggestion -> ErrorSuggestion+-- TODO: Adding a newline because source spans chomp everything up to the next character+  toSuggestion (P.ErrorSuggestion s) = ErrorSuggestion $ if null s then s else s ++ "\n"
psc/Main.hs view
@@ -27,6 +27,9 @@ import Data.List (isSuffixOf, partition) import Data.Version (showVersion) import qualified Data.Map as M+import qualified Data.Aeson as A+import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString.UTF8 as BU8  import Options.Applicative as Opts @@ -40,45 +43,54 @@  import Language.PureScript.Make +import JSON+ data PSCMakeOptions = PSCMakeOptions   { pscmInput        :: [FilePath]   , pscmForeignInput :: [FilePath]   , pscmOutputDir    :: FilePath   , pscmOpts         :: P.Options   , pscmUsePrefix    :: Bool+  , pscmJSONErrors   :: Bool   }  data InputOptions = InputOptions   { ioInputFiles  :: [FilePath]   } +-- | Argumnets: verbose, use JSON, warnings, errors+printWarningsAndErrors :: Bool -> Bool -> P.MultipleErrors -> Either P.MultipleErrors a -> IO ()+printWarningsAndErrors verbose False warnings errors = do+  when (P.nonEmpty warnings) $+    hPutStrLn stderr (P.prettyPrintMultipleWarnings verbose warnings)+  case errors of+    Left errs -> do+      hPutStrLn stderr (P.prettyPrintMultipleErrors verbose errs)+      exitFailure+    Right _ -> return ()+printWarningsAndErrors verbose True warnings errors = do+  hPutStrLn stderr . BU8.toString . B.toStrict . A.encode $+    JSONResult (toJSONErrors verbose P.Warning warnings)+               (either (toJSONErrors verbose P.Error) (const []) errors)+  either (const exitFailure) (const (return ())) errors+ compile :: PSCMakeOptions -> IO ()-compile (PSCMakeOptions inputGlob inputForeignGlob outputDir opts usePrefix) = do-  input <- globWarningOnMisses warnFileTypeNotFound inputGlob-  when (null input) $ do+compile PSCMakeOptions{..} = do+  input <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmInput+  when (null input && not pscmJSONErrors) $ do     hPutStrLn stderr "psc: No input files."     exitFailure   let (jsFiles, pursFiles) = partition (isSuffixOf ".js") input   moduleFiles <- readInput (InputOptions pursFiles)-  inputForeign <- globWarningOnMisses warnFileTypeNotFound inputForeignGlob+  inputForeign <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmForeignInput   foreignFiles <- forM (inputForeign ++ jsFiles) (\inFile -> (inFile,) <$> readUTF8File inFile)-  case runWriterT (parseInputs moduleFiles foreignFiles) of-    Left errs -> do-      hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)-      exitFailure-    Right ((ms, foreigns), warnings) -> do-      when (P.nonEmpty warnings) $-        hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)-      let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, fp)) ms-          makeActions = buildMakeActions outputDir filePathMap foreigns usePrefix-      (e, warnings') <- runMake opts $ P.make makeActions (map snd ms)-      when (P.nonEmpty warnings') $-        hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings')-      case e of-        Left errs -> do-          hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)-          exitFailure-        Right _ -> exitSuccess+  (makeErrors, makeWarnings) <- runMake pscmOpts $ do+    (ms, foreigns) <- parseInputs moduleFiles foreignFiles+    let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, fp)) ms+        makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix+    P.make makeActions (map snd ms)+  printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors makeWarnings makeErrors+  exitSuccess  warnFileTypeNotFound :: String -> IO () warnFileTypeNotFound = hPutStrLn stderr . ("psc: No files found using pattern: " ++)@@ -161,6 +173,10 @@   <> long "no-prefix"   <> help "Do not include comment header" +jsonErrors :: Parser Bool+jsonErrors = switch $+     long "json-errors"+  <> help "Print errors to stderr as JSON"  options :: Parser P.Options options = P.Options <$> noTco@@ -177,7 +193,7 @@                                 <*> outputDirectory                                 <*> options                                 <*> (not <$> noPrefix)-+                                <*> jsonErrors  main :: IO () main = execParser opts >>= compile
psci/Completion.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE DataKinds #-}+ module Completion where  import Prelude ()@@ -184,10 +186,10 @@ nubOnFst :: Eq a => [(a, b)] -> [(a, b)] nubOnFst = nubBy ((==) `on` fst) -typeDecls :: P.Module -> [(N.ProperName, P.Declaration)]+typeDecls :: P.Module -> [(N.ProperName 'N.TypeName, P.Declaration)] typeDecls = mapMaybe getTypeName . filter P.isDataDecl . P.exportedDeclarations   where-  getTypeName :: P.Declaration -> Maybe (N.ProperName, P.Declaration)+  getTypeName :: P.Declaration -> Maybe (N.ProperName 'N.TypeName, P.Declaration)   getTypeName d@(P.TypeSynonymDeclaration name _ _) = Just (name, d)   getTypeName d@(P.DataDeclaration _ name _ _) = Just (name, d)   getTypeName (P.PositionedDeclaration _ _ d) = getTypeName d@@ -204,10 +206,10 @@   getDeclNames (P.PositionedDeclaration _ _ d) = getDeclNames d   getDeclNames _ = [] -dctorNames :: P.Module -> [(N.ProperName, P.Declaration)]+dctorNames :: P.Module -> [(N.ProperName 'N.ConstructorName, P.Declaration)] dctorNames = nubOnFst . concatMap go . P.exportedDeclarations   where-  go :: P.Declaration -> [(N.ProperName, P.Declaration)]+  go :: P.Declaration -> [(N.ProperName 'N.ConstructorName, P.Declaration)]   go decl@(P.DataDeclaration _ _ _ ctors) = map (\n -> (n, decl)) (map fst ctors)   go (P.PositionedDeclaration _ _ d) = go d   go _ = []
psci/PSCi.hs view
@@ -1,23 +1,12 @@------------------------------------------------------------------------------------ Module      :  PSCi--- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess--- License     :  MIT (http://opensource.org/licenses/MIT)------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- PureScript Compiler Interactive.---------------------------------------------------------------------------------- {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE DataKinds #-} +-- |+-- PureScript Compiler Interactive.+-- module PSCi where  import Prelude ()@@ -25,7 +14,7 @@  import Data.Foldable (traverse_) import Data.Maybe (mapMaybe)-import Data.List (intersperse, intercalate, nub, sort)+import Data.List (intersperse, intercalate, nub, sort, find) import Data.Tuple (swap) import Data.Version (showVersion) import qualified Data.Map as M@@ -125,12 +114,12 @@ -- | -- Load all modules. ---loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(Either P.RebuildPolicy FilePath, P.Module)])+loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)]) loadAllModules files = do   filesAndContent <- forM files $ \filename -> do     content <- readFile filename-    return (Right filename, content)-  return $ P.parseModulesFromFiles (either (const "") id) filesAndContent+    return (filename, content)+  return $ P.parseModulesFromFiles id filesAndContent  -- | -- Load all modules, updating the application state@@ -141,7 +130,7 @@   modulesOrFirstError <- psciIO $ loadAllModules files   case modulesOrFirstError of     Left errs -> printErrors errs-    Right modules -> PSCI . lift . modify $ \st -> st { psciLoadedModules = modules }+    Right modules -> PSCI . lift . modify $ updateModules modules  -- | -- Expands tilde in path.@@ -214,7 +203,7 @@     trace = P.Var (P.Qualified (Just supportModuleName) (P.Ident "eval"))     mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))     itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val-    mainDecl = P.ValueDeclaration (P.Ident "main") P.Public [] $ Right mainValue+    mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] $ Right mainValue     decls = if exec then [itDecl, mainDecl] else [itDecl]   in     P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing@@ -242,7 +231,7 @@     P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName (importDecl `map` imports) Nothing  importDecl :: ImportedModule -> P.Declaration-importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ+importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ False  indexFile :: FilePath indexFile = ".psci_modules" ++ pathSeparator : "index.js"@@ -260,26 +249,28 @@   e <- liftIO $ tryIOError io   either (throwError . P.singleError . f) return e -make :: PSCiState -> [(Either P.RebuildPolicy FilePath, P.Module)] -> P.Make P.Environment-make PSCiState{..} ms = P.make actions' (map snd (psciLoadedModules ++ ms))+make :: PSCiState -> [P.Module] -> P.Make P.Environment+make st@PSCiState{..} ms = P.make actions' (map snd loadedModules ++ ms)   where-  filePathMap = M.fromList $ (first P.getModuleName . swap) `map` (psciLoadedModules ++ ms)+  filePathMap = M.fromList $ (first P.getModuleName . swap) `map` allModules   actions = P.buildMakeActions modulesDir filePathMap psciForeignFiles False   actions' = actions { P.progress = const (return ()) }+  loadedModules = psciLoadedModules st+  allModules = map (first Right) loadedModules ++ map (Left P.RebuildAlways,) ms  -- |--- Takes a value declaration and evaluates it with the current state.+-- Takes a value expression and evaluates it with the current state. ---handleDeclaration :: P.Expr -> PSCI ()-handleDeclaration val = do+handleExpression :: P.Expr -> PSCI ()+handleExpression val = do   st <- PSCI $ lift get   let m = createTemporaryModule True st val   let nodeArgs = psciNodeFlags st ++ [indexFile]-  e <- psciIO . runMake $ make st [(Left P.RebuildAlways, supportModule), (Left P.RebuildAlways, m)]+  e <- psciIO . runMake $ make st [supportModule, m]   case e of     Left errs -> printErrors errs     Right _ -> do-      psciIO $ writeFile indexFile "require('$PSCI').main();"+      psciIO $ writeFile indexFile "require('$PSCI')['$main']();"       process <- psciIO findNodeProcess       result  <- psciIO $ traverse (\node -> readProcessWithExitCode node nodeArgs "") process       case result of@@ -296,7 +287,7 @@   st <- PSCI $ lift get   let st' = updateLets ds st   let m = createTemporaryModule False st' (P.ObjectLiteral [])-  e <- psciIO . runMake $ make st' [(Left P.RebuildAlways, m)]+  e <- psciIO . runMake $ make st' [m]   case e of     Left err -> printErrors err     Right _ -> PSCI $ lift (put st')@@ -306,7 +297,7 @@ -- handleShowLoadedModules :: PSCI () handleShowLoadedModules = do-  PSCiState { psciLoadedModules = loadedModules } <- PSCI $ lift get+  loadedModules <- PSCI $ lift $ gets psciLoadedModules   psciIO $ readModules loadedModules >>= putStrLn   return ()   where readModules = return . unlines . sort . nub . map toModuleName@@ -329,15 +320,16 @@    showDeclType P.Implicit = ""   showDeclType (P.Explicit refs) = refsList refs-  showDeclType (P.Hiding refs) = "hiding " ++ refsList refs-  refsList refs = "(" ++ commaList (map showRef refs) ++ ")"+  showDeclType (P.Hiding refs) = " hiding " ++ refsList refs+  refsList refs = " (" ++ commaList (map showRef refs) ++ ")"    showRef :: P.DeclarationRef -> String-  showRef (P.TypeRef pn dctors) = show pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"-  showRef (P.ValueRef ident) = show ident-  showRef (P.TypeClassRef pn) = show pn-  showRef (P.TypeInstanceRef ident) = show ident-  showRef (P.ModuleRef name) = "module " ++ show name+  showRef (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"+  showRef (P.ValueRef ident) = N.runIdent ident+  showRef (P.TypeClassRef pn) = N.runProperName pn+  showRef (P.ProperRef pn) = pn+  showRef (P.TypeInstanceRef ident) = N.runIdent ident+  showRef (P.ModuleRef name) = "module " ++ N.runModuleName name   showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref    commaList :: [String] -> String@@ -350,7 +342,7 @@ handleImport im = do    st <- updateImportedModules im <$> PSCI (lift get)    let m = createTemporaryModuleForImports st-   e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)]+   e <- psciIO . runMake $ make st [m]    case e of      Left errs -> printErrors errs      Right _  -> do@@ -364,7 +356,7 @@ handleTypeOf val = do   st <- PSCI $ lift get   let m = createTemporaryModule False st val-  e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)]+  e <- psciIO . runMake $ make st [m]   case e of     Left errs -> printErrors errs     Right env' ->@@ -400,10 +392,15 @@         showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType         showNameType _ = P.internalError "The impossible happened in printModuleSignatures." -        findTypeClass :: M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]) -> P.Qualified P.ProperName -> (P.Qualified P.ProperName, Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))+        findTypeClass+          :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])+          -> P.Qualified (P.ProperName 'P.ClassName)+          -> (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))         findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses) -        showTypeClass :: (P.Qualified P.ProperName, Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) -> Maybe Box.Box+        showTypeClass+          :: (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))+          -> Maybe Box.Box         showTypeClass (_, Nothing) = Nothing         showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) =             let constraints =@@ -427,18 +424,22 @@                 Box.// Box.moveRight 2 classBody  -        findType :: M.Map (P.Qualified P.ProperName) (P.Kind, P.TypeKind) -> P.Qualified P.ProperName -> (P.Qualified P.ProperName, Maybe (P.Kind, P.TypeKind))+        findType+          :: M.Map (P.Qualified (P.ProperName 'P.TypeName)) (P.Kind, P.TypeKind)+          -> P.Qualified (P.ProperName 'P.TypeName)+          -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))         findType envTypes name = (name, M.lookup name envTypes) -        showType :: M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])-                 -> M.Map (P.Qualified P.ProperName) (P.DataDeclType, P.ProperName, P.Type, [P.Ident])-                 -> M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], P.Type)-                 -> (P.Qualified P.ProperName, Maybe (P.Kind, P.TypeKind))-                 -> Maybe Box.Box+        showType+          :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])+          -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident])+          -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(String, Maybe P.Kind)], P.Type)+          -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))+          -> Maybe Box.Box         showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) =           case (typ, M.lookup n typeSynonymsEnv) of             (Just (_, P.TypeSynonym), Just (typevars, dtType)) ->-                if M.member n typeClassesEnv+                if M.member (fmap P.coerceProperName n) typeClassesEnv                 then                   Nothing                 else@@ -485,9 +486,22 @@   case env of     Left errs -> printErrors errs     Right env' ->-      if moduleName `notElem` (nub . map ((\ (P.Module _ _ modName _ _ ) -> modName) . snd)) (psciLoadedModules st)-        then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."-        else printModuleSignatures moduleName env'+      if isModInEnv moduleName st+        then printModuleSignatures moduleName env'+        else case lookupUnQualifiedModName moduleName st of+          Just unQualifiedName ->+            if isModInEnv unQualifiedName st+              then printModuleSignatures unQualifiedName env'+              else failNotInEnv moduleName+          Nothing ->+            failNotInEnv moduleName+  where+    isModInEnv modName =+        any ((== modName) . P.getModuleName . snd) . psciLoadedModules+    failNotInEnv modName =+        PSCI $ outputStrLn $ "Module '" ++ N.runModuleName modName ++ "' is not valid."+    lookupUnQualifiedModName quaModName st =+        (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st)  -- | Pretty-print errors printErrors :: P.MultipleErrors -> PSCI ()@@ -501,7 +515,7 @@   st <- PSCI $ lift get   let m = createTemporaryModuleForKind st typ       mName = P.ModuleName [P.ProperName "$PSCI"]-  e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)]+  e <- psciIO . runMake $ make st [m]   case e of     Left errs -> printErrors errs     Right env' ->@@ -538,16 +552,15 @@ -- Performs an action for each meta-command given, and also for expressions. -- handleCommand :: Command -> PSCI ()-handleCommand (Expression val) = handleDeclaration val+handleCommand (Expression val) = handleExpression val handleCommand ShowHelp = PSCI $ outputStrLn helpMessage handleCommand (Import im) = handleImport im handleCommand (Decls l) = handleDecls l handleCommand (LoadFile filePath) = whenFileExists filePath $ \absPath -> do-  PSCI . lift $ modify (updateImportedFiles absPath)   m <- psciIO $ loadModule absPath   case m of     Left err -> PSCI $ outputStrLn err-    Right mods -> PSCI . lift $ modify (updateModules (map ((,) (Right absPath)) mods))+    Right mods -> PSCI . lift $ modify (updateModules (map (absPath,) mods)) handleCommand (LoadForeign filePath) = whenFileExists filePath $ \absPath -> do   foreignsOrError <- psciIO . runMake $ do     foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readFile absPath)@@ -556,12 +569,10 @@     Left err -> PSCI $ outputStrLn $ P.prettyPrintMultipleErrors False err     Right foreigns -> PSCI . lift $ modify (updateForeignFiles foreigns) handleCommand ResetState = do-  files <- psciImportedFilenames <$> PSCI (lift get)-  PSCI . lift . modify $ \st -> st-    { psciImportedFilenames   = files-    , psciImportedModules     = []-    , psciLetBindings         = []-    }+  PSCI . lift . modify $ \st ->+    st { psciImportedModules = []+       , psciLetBindings     = []+       }   loadAllImportedModules handleCommand (TypeOf val) = handleTypeOf val handleCommand (KindOf typ) = handleKindOf typ@@ -624,7 +635,7 @@       case foreignsOrError of         Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure         Right foreigns ->-          flip evalStateT (PSCiState inputFiles [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do+          flip evalStateT (mkPSCiState [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do             outputStrLn prologueMessage             traverse_ (traverse_ (runPSCI . handleCommand)) config             modules' <- lift $ gets psciLoadedModules
psci/Parser.hs view
@@ -106,7 +106,9 @@ -- | Imports must be handled separately from other declarations, so that -- :show import works, for example. psciImport :: P.TokenParser Command-psciImport = Import <$> P.parseImportDeclaration'+psciImport = do+  (mn, declType, asQ, _) <- P.parseImportDeclaration'+  return $ Import (mn, declType, asQ)  -- | Any other declaration that we don't need a 'special case' parser for -- (like let or import declarations).
psci/Types.hs view
@@ -15,7 +15,9 @@  module Types where -import qualified Data.Map as M+import Control.Arrow (second)+import Data.Map (Map)+import qualified Data.Map as Map import qualified Language.PureScript as P  data PSCiOptions = PSCiOptions@@ -32,14 +34,48 @@ -- because it makes more sense to apply the binding to the final evaluated expression. -- data PSCiState = PSCiState-  { psciImportedFilenames   :: [FilePath]-  , psciImportedModules     :: [ImportedModule]-  , psciLoadedModules       :: [(Either P.RebuildPolicy FilePath, P.Module)]-  , psciForeignFiles        :: M.Map P.ModuleName FilePath+  { psciImportedModules     :: [ImportedModule]+  , _psciLoadedModules      :: Map FilePath [P.Module]+  , psciForeignFiles        :: Map P.ModuleName FilePath   , psciLetBindings         :: [P.Declaration]   , psciNodeFlags           :: [String]   } +initialPSCiState :: PSCiState+initialPSCiState =+  PSCiState [] Map.empty Map.empty [] []++mkPSCiState :: [ImportedModule]+            -> [(FilePath, P.Module)]+            -> Map P.ModuleName FilePath+            -> [P.Declaration]+            -> [String]+            -> PSCiState+mkPSCiState imported loaded foreigns lets nodeFlags =+  (initialPSCiState+    |> each imported updateImportedModules+    |> updateModules loaded)+    { psciForeignFiles = foreigns+    , psciLetBindings = lets+    , psciNodeFlags = nodeFlags+    }+  where+  x |> f = f x+  each xs f st = foldl (flip f) st xs++--  Public psci state accessors++-- | Get the imported filenames as a list.+psciImportedFilenames :: PSCiState -> [FilePath]+psciImportedFilenames = Map.keys . _psciLoadedModules++-- | Get the loaded modules as a list.+psciLoadedModules :: PSCiState -> [(FilePath, P.Module)]+psciLoadedModules = collect . Map.toList . _psciLoadedModules+  where+  collect :: [(k, [v])] -> [(k, v)]+  collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ]+ -- | All of the data that is contained by an ImportDeclaration in the AST. -- That is: --@@ -67,20 +103,18 @@ -- | -- Updates the state to have more imported modules. ---updateImportedFiles :: FilePath -> PSCiState -> PSCiState-updateImportedFiles filename st = st { psciImportedFilenames = filename : psciImportedFilenames st }---- |--- Updates the state to have more imported modules.--- updateImportedModules :: ImportedModule -> PSCiState -> PSCiState updateImportedModules im st = st { psciImportedModules = im : psciImportedModules st }  -- |--- Updates the state to have more loaded files.+-- Updates the state to have more loaded modules (available for import, but+-- not necessarily imported). ---updateModules :: [(Either P.RebuildPolicy FilePath, P.Module)] -> PSCiState -> PSCiState-updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules }+updateModules :: [(FilePath, P.Module)] -> PSCiState -> PSCiState+updateModules modules st =+  st { _psciLoadedModules = Map.union (go modules) (_psciLoadedModules st) }+  where+  go = Map.fromListWith (++) . map (second (:[]))  -- | -- Updates the state to have more let bindings.@@ -91,8 +125,8 @@ -- | -- Updates the state to have more let bindings. ---updateForeignFiles :: M.Map P.ModuleName FilePath -> PSCiState -> PSCiState-updateForeignFiles fs st = st { psciForeignFiles = psciForeignFiles st `M.union` fs }+updateForeignFiles :: Map P.ModuleName FilePath -> PSCiState -> PSCiState+updateForeignFiles fs st = st { psciForeignFiles = psciForeignFiles st `Map.union` fs }  -- | -- Valid Meta-commands for PSCI
psci/tests/Main.hs view
@@ -142,7 +142,7 @@       print err >> exitFailure     Right modules ->       let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)]-      in  return (PSCiState [] imports modules foreigns [] [])+      in  return (mkPSCiState imports modules foreigns [] [])  controlMonadSTasST :: ImportedModule controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST"))
purescript.cabal view
@@ -1,5 +1,5 @@ name: purescript-version: 0.7.6.1+version: 0.8.0.0 cabal-version: >=1.8 build-type: Simple license: MIT@@ -20,6 +20,9 @@  extra-source-files: examples/passing/*.purs                   , examples/failing/*.purs+                  , examples/docs/bower_components/purescript-prelude/src/*.purs+                  , examples/docs/bower.json+                  , examples/docs/src/*.purs                   , tests/support/setup.js                   , tests/support/package.json                   , tests/support/bower.json@@ -159,6 +162,8 @@                       Language.PureScript.Docs                      Language.PureScript.Docs.Convert+                     Language.PureScript.Docs.Convert.Single+                     Language.PureScript.Docs.Convert.ReExports                      Language.PureScript.Docs.Render                      Language.PureScript.Docs.Types                      Language.PureScript.Docs.RenderedCode@@ -178,6 +183,8 @@                      Control.Monad.Supply.Class                       System.IO.UTF8++    extensions:      DataKinds     exposed: True     buildable: True     hs-source-dirs: src@@ -185,12 +192,15 @@     ghc-options: -Wall -O2  executable psc-    build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,+    build-depends: base >=4 && <5, base-compat >=0.6.0,+                   containers -any, directory -any, filepath -any,                    mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,-                   time -any, transformers -any, transformers-compat -any, Glob >= 0.7 && < 0.8+                   time -any, transformers -any, transformers-compat -any, Glob >= 0.7 && < 0.8,+                   aeson >= 0.8 && < 0.11, bytestring -any, utf8-string >= 1 && < 2     main-is: Main.hs     buildable: True     hs-source-dirs: psc+    other-modules: JSON     ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N"  executable psci@@ -215,7 +225,8 @@     build-depends: base >=4 && <5, purescript -any,                    optparse-applicative >= 0.10.0, process -any, mtl -any,                    split -any, ansi-wl-pprint -any, directory -any,-                   filepath -any, Glob -any+                   filepath -any, Glob -any, transformers -any,+                   transformers-compat -any     main-is: Main.hs     buildable: True     hs-source-dirs: psc-docs@@ -261,10 +272,13 @@     build-depends: base >=4 && <5, containers -any, directory -any,                    filepath -any, mtl -any, parsec -any, purescript -any,                    transformers -any, process -any, transformers-compat -any, time -any,-                   Glob -any, base-compat >=0.6.0+                   Glob -any, aeson-better-errors -any, bytestring -any, aeson -any,+                   base-compat -any     type: exitcode-stdio-1.0     main-is: Main.hs     other-modules: TestsSetup+                   TestPscPublish+                   TestDocs     buildable: True     hs-source-dirs: tests tests/common
src/Control/Monad/Logger.hs view
@@ -30,7 +30,7 @@ import Control.Monad.Trans.Control (MonadBaseControl(..))  -- | A replacement for WriterT IO which uses mutable references.-data Logger w a = Logger { runLogger :: IORef w -> IO a }+newtype Logger w a = Logger { runLogger :: IORef w -> IO a }  -- | Run a Logger computation, starting with an empty log. runLogger' :: (Monoid w) => Logger w a -> IO (a, w)
src/Control/Monad/Supply/Class.hs view
@@ -1,20 +1,8 @@------------------------------------------------------------------------------------ Module      :  Control.Monad.Supply.Class--- Copyright   :  (c) PureScript 2015--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :---+{-# LANGUAGE MultiParamTypeClasses #-}+ -- | -- A class for monads supporting a supply of fresh names ----------------------------------------------------------------------------------{-# LANGUAGE MultiParamTypeClasses #-}- module Control.Monad.Supply.Class where  import Control.Monad.Supply@@ -22,15 +10,15 @@  class (Monad m) => MonadSupply m where   fresh :: m Integer-  + 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  freshName :: (MonadSupply m) => m String-freshName = liftM (('_' :) . show) fresh+freshName = liftM (('$' :) . show) fresh
src/Language/PureScript.hs view
@@ -13,7 +13,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}
src/Language/PureScript/AST/Binders.hs view
@@ -1,23 +1,8 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.AST.Binders--- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ | Case binders+-- |+-- Case binders ----------------------------------------------------------------------------------{-# LANGUAGE DeriveDataTypeable #-}- module Language.PureScript.AST.Binders where -import qualified Data.Data as D- import Language.PureScript.AST.SourcePos import Language.PureScript.Names import Language.PureScript.Comments@@ -54,7 +39,7 @@   -- |   -- A binder which matches a data constructor   ---  | ConstructorBinder (Qualified ProperName) [Binder]+  | ConstructorBinder (Qualified (ProperName 'ConstructorName)) [Binder]   -- |   -- A binder which matches a record and binds its properties   --@@ -74,7 +59,8 @@   -- |   -- A binder with a type annotation   ---  | TypedBinder Type Binder deriving (Show, Read, Eq, D.Data, D.Typeable)+  | TypedBinder Type Binder+  deriving (Show, Read, Eq)  -- | -- Collect all names introduced in binders in an expression
src/Language/PureScript/AST/Declarations.hs view
@@ -1,29 +1,19 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.AST.Declarations--- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess--- License     :  MIT (http://opensource.org/licenses/MIT)------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ | Data types for modules and declarations-----------------------------------------------------------------------------------{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE LambdaCase #-} +-- |+-- Data types for modules and declarations+-- module Language.PureScript.AST.Declarations where  import Prelude () import Prelude.Compat  import Data.Aeson.TH+import Data.List (nub, (\\))+import Data.Maybe (mapMaybe) -import qualified Data.Data as D import qualified Data.Map as M  import Control.Monad.Identity@@ -43,20 +33,33 @@ -- a list of declarations, and a list of the declarations that are -- explicitly exported. If the export list is Nothing, everything is exported. ---data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, Read, D.Data, D.Typeable)+data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef])+  deriving (Show, Read)  -- | Return a module's name. getModuleName :: Module -> ModuleName getModuleName (Module _ _ name _ _) = name  -- |+-- Add an import declaration for a module if it does not already explicitly import it.+--+addDefaultImport :: ModuleName -> Module -> Module+addDefaultImport toImport m@(Module ss coms mn decls exps)  =+  if isExistingImport `any` decls || mn == toImport then m+  else Module ss coms mn (ImportDeclaration toImport Implicit Nothing False : decls) exps+  where+  isExistingImport (ImportDeclaration mn' _ _ _) | mn' == toImport = True+  isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d+  isExistingImport _ = False++-- | -- An item in a list of explicit imports or exports -- data DeclarationRef   -- |   -- A type constructor with data constructors   ---  = TypeRef ProperName (Maybe [ProperName])+  = TypeRef (ProperName 'TypeName) (Maybe [ProperName 'ConstructorName])   -- |   -- A value   --@@ -64,7 +67,7 @@   -- |   -- A type class   ---  | TypeClassRef ProperName+  | TypeClassRef (ProperName 'ClassName)     -- |   -- A type class instance, created during typeclass desugaring (name, class name, instance types)   --@@ -74,31 +77,59 @@   --   | ModuleRef ModuleName   -- |+  -- An unspecified ProperName ref. This will be replaced with a TypeClassRef+  -- or TypeRef during name desugaring.+  | ProperRef String+  -- |   -- A declaration reference with source position information   --   | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef-  deriving (Show, Read, D.Data, D.Typeable)+  deriving (Show, Read)  instance Eq DeclarationRef where   (TypeRef name dctors)  == (TypeRef name' dctors') = name == name' && dctors == dctors'   (ValueRef name)        == (ValueRef name')        = name == name'   (TypeClassRef name)    == (TypeClassRef name')    = name == name'   (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'-  (ModuleRef name) == (ModuleRef name') = name == name'+  (ModuleRef name)       == (ModuleRef name')       = name == name'+  (ProperRef name)       == (ProperRef name')       = name == name'   (PositionedDeclarationRef _ _ r) == r' = r == r'   r == (PositionedDeclarationRef _ _ r') = r == r'   _ == _ = False  isModuleRef :: DeclarationRef -> Bool+isModuleRef (PositionedDeclarationRef _ _ r) = isModuleRef r isModuleRef (ModuleRef _) = True isModuleRef _ = False  -- |+-- Finds duplicate values in a list of declaration refs. The returned values+-- are the duplicate refs with data constructors elided, and then a separate+-- list of duplicate data constructors.+--+findDuplicateRefs :: [DeclarationRef] -> ([DeclarationRef], [ProperName 'ConstructorName])+findDuplicateRefs refs =+  let positionless = stripPosInfo `map` refs+      simplified = simplifyTypeRefs `map` positionless+      dupeRefs = nub $ simplified \\ nub simplified+      dupeCtors = concat $ flip mapMaybe positionless $ \case+        TypeRef _ (Just dctors) ->+          let dupes = dctors \\ nub dctors+          in if null dupes then Nothing else Just dupes+        _ -> Nothing+  in (dupeRefs, dupeCtors)+  where+  stripPosInfo (PositionedDeclarationRef _ _ ref) = stripPosInfo ref+  stripPosInfo other = other+  simplifyTypeRefs (TypeRef pn _) = TypeRef pn Nothing+  simplifyTypeRefs other = other++-- | -- The data type which specifies type of import declaration -- data ImportDeclarationType   -- |-  -- An import with no explicit list: `import M`+  -- An import with no explicit list: `import M`.   --   = Implicit   -- |@@ -109,8 +140,16 @@   -- An import with a list of references to hide: `import M hiding (foo)`   --   | Hiding [DeclarationRef]-  deriving (Show, Read, D.Data, D.Typeable)+  deriving (Eq, Show, Read) +isImplicit :: ImportDeclarationType -> Bool+isImplicit Implicit = True+isImplicit _ = False++isExplicit :: ImportDeclarationType -> Bool+isExplicit (Explicit _) = True+isExplicit _ = False+ -- | -- The data type of declarations --@@ -118,7 +157,7 @@   -- |   -- A data type declaration (data or newtype, name, arguments, data constructors)   ---  = DataDeclaration DataDeclType ProperName [(String, Maybe Kind)] [(ProperName, [Type])]+  = DataDeclaration DataDeclType (ProperName 'TypeName) [(String, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]   -- |   -- A minimal mutually recursive set of data type declarations   --@@ -126,7 +165,7 @@   -- |   -- A type synonym declaration (name, arguments, type)   ---  | TypeSynonymDeclaration ProperName [(String, Maybe Kind)] Type+  | TypeSynonymDeclaration (ProperName 'TypeName) [(String, Maybe Kind)] Type   -- |   -- A type declaration for a value (name, ty)   --@@ -146,29 +185,30 @@   -- |   -- A data type foreign import (name, kind)   ---  | ExternDataDeclaration ProperName Kind+  | ExternDataDeclaration (ProperName 'TypeName) Kind   -- |-  -- A fixity declaration (fixity data, operator name)+  -- A fixity declaration (fixity data, operator name, value the operator is an alias for)   ---  | FixityDeclaration Fixity String+  | FixityDeclaration Fixity String (Maybe (Qualified Ident))   -- |   -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)+  -- TODO: also a boolean specifying whether the old `qualified` syntax was used, so a warning can be raised in desugaring (remove for 0.9)   ---  | ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName)+  | ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName) Bool   -- |   -- A type class declaration (name, argument, implies, member declarations)   ---  | TypeClassDeclaration ProperName [(String, Maybe Kind)] [Constraint] [Declaration]+  | TypeClassDeclaration (ProperName 'ClassName) [(String, Maybe Kind)] [Constraint] [Declaration]   -- |   -- A type instance declaration (name, dependencies, class name, instance types, member   -- declarations)   ---  | TypeInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type] TypeInstanceBody+  | TypeInstanceDeclaration Ident [Constraint] (Qualified (ProperName 'ClassName)) [Type] TypeInstanceBody   -- |   -- A declaration with source position information   --   | PositionedDeclaration SourceSpan [Comment] Declaration-  deriving (Show, Read, D.Data, D.Typeable)+  deriving (Show, Read)  -- | The members of a type class instance declaration data TypeInstanceBody@@ -176,7 +216,7 @@   = DerivedInstance   -- | This is a regular (explicit) instance   | ExplicitInstance [Declaration]-  deriving (Show, Read, D.Data, D.Typeable)+  deriving (Show, Read)  mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)@@ -353,7 +393,7 @@   -- |   -- A data constructor   ---  | Constructor (Qualified ProperName)+  | Constructor (Qualified (ProperName 'ConstructorName))   -- |   -- A case expression. During the case expansion phase of desugaring, top-level binders will get   -- desugared into case expressions, hence the need for guards and multiple binders per branch here.@@ -375,7 +415,7 @@   -- An application of a typeclass dictionary constructor. The value should be   -- an ObjectLiteral.   ---  | TypeClassDictionaryConstructorApp (Qualified ProperName) Expr+  | TypeClassDictionaryConstructorApp (Qualified (ProperName 'ClassName)) Expr   -- |   -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these   -- placeholders will be replaced with actual expressions representing type classes dictionaries which@@ -383,19 +423,20 @@   -- at superclass implementations when searching for a dictionary, the type class name and   -- instance type, and the type class dictionaries in scope.   ---  | TypeClassDictionary Constraint (M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))+  | TypeClassDictionary Constraint (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))   -- |   -- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring.   ---  | TypeClassDictionaryAccessor (Qualified ProperName) Ident+  | TypeClassDictionaryAccessor (Qualified (ProperName 'ClassName)) Ident   -- |   -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking   ---  | SuperClassDictionary (Qualified ProperName) [Type]+  | SuperClassDictionary (Qualified (ProperName 'ClassName)) [Type]   -- |   -- A value with source position information   ---  | PositionedValue SourceSpan [Comment] Expr deriving (Show, Read, D.Data, D.Typeable)+  | PositionedValue SourceSpan [Comment] Expr+  deriving (Show, Read)  -- | -- An alternative in a case statement@@ -409,7 +450,7 @@     -- The result expression or a collect of guarded expressions     --   , caseAlternativeResult :: Either [(Guard, Expr)] Expr-  } deriving (Show, Read, D.Data, D.Typeable)+  } deriving (Show, Read)  -- | -- A statement in a do-notation block@@ -430,7 +471,8 @@   -- |   -- A do notation element with source position information   ---  | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement deriving (Show, Read, D.Data, D.Typeable)+  | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement+  deriving (Show, Read)  $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType)
src/Language/PureScript/AST/Exported.hs view
@@ -1,8 +1,7 @@--module Language.PureScript.AST.Exported (-  exportedDeclarations,-  isExported-) where+module Language.PureScript.AST.Exported+  ( exportedDeclarations+  , isExported+  ) where  import Control.Category ((>>>)) import Data.Maybe (mapMaybe)@@ -23,12 +22,12 @@ -- instances will be incorrectly removed in some cases. -- exportedDeclarations :: Module -> [Declaration]-exportedDeclarations (Module _ _ _ decls exps) = go decls+exportedDeclarations (Module _ _ mn decls exps) = go decls   where   go = flattenDecls         >>> filter (isExported exps)         >>> map (filterDataConstructors exps)-        >>> filterInstances exps+        >>> filterInstances mn exps  -- | -- Filter out all data constructors from a declaration which are not exported.@@ -52,10 +51,15 @@ -- produce incorrect results if this is not the case - for example, type class -- instances will be incorrectly removed in some cases. ---filterInstances :: Maybe [DeclarationRef] -> [Declaration] -> [Declaration]-filterInstances Nothing = id-filterInstances (Just exps) =-  let refs = mapMaybe typeName exps ++ mapMaybe typeClassName exps+filterInstances+  :: ModuleName+  -> Maybe [DeclarationRef]+  -> [Declaration]+  -> [Declaration]+filterInstances _ Nothing = id+filterInstances mn (Just exps) =+  let refs = Left `map` mapMaybe typeClassName exps+          ++ Right `map` mapMaybe typeName exps   in filter (all (visibleOutside refs) . typeInstanceConstituents)   where   -- Given a Qualified ProperName, and a list of all exported types and type@@ -65,13 +69,24 @@   --  * the name is defined in the same module and is exported,   --  * the name is defined in a different module (and must be exported from   --    that module; the code would fail to compile otherwise).-  visibleOutside _ (Qualified (Just _) _) = True-  visibleOutside refs (Qualified Nothing n) = n `elem` refs+  visibleOutside+    :: [Either (ProperName 'ClassName) (ProperName 'TypeName)]+    -> Either (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'TypeName))+    -> Bool+  visibleOutside refs q+    | either checkQual checkQual q = True+    | otherwise = either (Left . disqualify) (Right . disqualify) q `elem` refs +  -- Check that a qualified name is qualified for a different module+  checkQual :: Qualified a -> Bool+  checkQual q = isQualified q && not (isQualifiedWith mn q)++  typeName :: DeclarationRef -> Maybe (ProperName 'TypeName)   typeName (TypeRef n _) = Just n   typeName (PositionedDeclarationRef _ _ r) = typeName r   typeName _ = Nothing +  typeClassName :: DeclarationRef -> Maybe (ProperName 'ClassName)   typeClassName (TypeClassRef n) = Just n   typeClassName (PositionedDeclarationRef _ _ r) = typeClassName r   typeClassName _ = Nothing@@ -79,17 +94,17 @@ -- | -- Get all type and type class names referenced by a type instance declaration. ---typeInstanceConstituents :: Declaration -> [Qualified ProperName]+typeInstanceConstituents :: Declaration -> [Either (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'TypeName))] typeInstanceConstituents (TypeInstanceDeclaration _ constraints className tys _) =-  className : (concatMap fromConstraint constraints ++ concatMap fromType tys)+  Left className : (concatMap fromConstraint constraints ++ concatMap fromType tys)   where -  fromConstraint (name, tys') = name : concatMap fromType tys'+  fromConstraint (name, tys') = Left name : concatMap fromType tys'   fromType = everythingOnTypes (++) go    -- Note that type synonyms are disallowed in instance declarations, so   -- we don't need to handle them here.-  go (TypeConstructor n) = [n]+  go (TypeConstructor n) = [Right n]   go (ConstrainedType cs _) = concatMap fromConstraint cs   go _ = [] @@ -112,12 +127,15 @@   matches (TypeDeclaration ident _)          (ValueRef ident')     = ident == ident'   matches (ValueDeclaration ident _ _ _)     (ValueRef ident')     = ident == ident'   matches (ExternDeclaration ident _)        (ValueRef ident')     = ident == ident'-  matches (FixityDeclaration _ name)         (ValueRef ident')     = name == runIdent ident'+  matches (FixityDeclaration _ name _)       (ValueRef ident')     = name == runIdent ident'   matches (DataDeclaration _ ident _ _)      (TypeRef ident' _)    = ident == ident'   matches (ExternDataDeclaration ident _)    (TypeRef ident' _)    = ident == ident'   matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _)    = ident == ident'   matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident' +  matches (DataDeclaration _ ident _ _)      (ProperRef ident')    = runProperName ident == ident'+  matches (TypeClassDeclaration ident _ _ _) (ProperRef ident')    = runProperName ident == ident'+   matches (PositionedDeclaration _ _ d) r = d `matches` r   matches d (PositionedDeclarationRef _ _ r) = d `matches` r   matches _ _ = False@@ -126,7 +144,7 @@ -- Test if a data constructor for a given type is exported, given a module's -- export list. Prefer 'exportedDeclarations' to this function, where possible. ---isDctorExported :: ProperName -> Maybe [DeclarationRef] -> ProperName -> Bool+isDctorExported :: ProperName 'TypeName -> Maybe [DeclarationRef] -> ProperName 'ConstructorName -> Bool isDctorExported _ Nothing _ = True isDctorExported ident (Just exps) ctor = test `any` exps   where
src/Language/PureScript/AST/Operators.hs view
@@ -1,23 +1,10 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.AST.Operators--- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ | Operators fixity and associativity---------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveDataTypeable #-} +-- |+-- Operators fixity and associativity+-- module Language.PureScript.AST.Operators where -import qualified Data.Data as D import Data.Aeson ((.=)) import qualified Data.Aeson as A @@ -31,7 +18,8 @@ -- | -- Associativity for infix operators ---data Associativity = Infixl | Infixr | Infix deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)+data Associativity = Infixl | Infixr | Infix+  deriving (Show, Read, Eq, Ord)  showAssoc :: Associativity -> String showAssoc Infixl = "infixl"@@ -53,7 +41,8 @@ -- | -- Fixity data for infix operators ---data Fixity = Fixity Associativity Precedence deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)+data Fixity = Fixity Associativity Precedence+  deriving (Show, Read, Eq, Ord)  instance A.ToJSON Fixity where   toJSON (Fixity associativity precedence) =
src/Language/PureScript/AST/SourcePos.hs view
@@ -1,28 +1,15 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.AST.SourcePos--- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess--- License     :  MIT (http://opensource.org/licenses/MIT)------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ | Source position information-----------------------------------------------------------------------------------{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} +-- |+-- Source position information+-- module Language.PureScript.AST.SourcePos where  import Prelude () import Prelude.Compat -import qualified Data.Data as D import Data.Aeson ((.=), (.:)) import qualified Data.Aeson as A @@ -38,7 +25,7 @@     -- Column number     --   , sourcePosColumn :: Int-  } deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)+  } deriving (Show, Read, Eq, Ord)  displaySourcePos :: SourcePos -> String displaySourcePos sp =@@ -66,7 +53,7 @@     -- End of the span     --   , spanEnd :: SourcePos-  } deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)+  } deriving (Show, Read, Eq, Ord)  displayStartEndPos :: SourceSpan -> String displayStartEndPos sp =
src/Language/PureScript/AST/Traversals.hs view
@@ -18,6 +18,10 @@ import Prelude.Compat  import Data.Maybe (mapMaybe)+import Data.List (mapAccumL)+import Data.Foldable (fold)+import qualified Data.Set as S+ import Control.Monad import Control.Arrow ((***), (+++), second) @@ -25,6 +29,7 @@ import Language.PureScript.AST.Declarations import Language.PureScript.Types import Language.PureScript.Traversals+import Language.PureScript.Names  everywhereOnValues :: (Declaration -> Declaration) ->                       (Expr -> Expr) ->@@ -388,6 +393,112 @@   j' s (DoNotationBind b v) = DoNotationBind <$> h'' s b <*> g'' s v   j' s (DoNotationLet ds) = DoNotationLet <$> traverse (f'' s) ds   j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1++everythingWithScope ::+  (Monoid r) =>+  (S.Set Ident -> Declaration -> r) ->+  (S.Set Ident -> Expr -> r) ->+  (S.Set Ident -> Binder -> r) ->+  (S.Set Ident -> CaseAlternative -> r) ->+  (S.Set Ident -> DoNotationElement -> r) ->+  ( S.Set Ident -> Declaration       -> r+  , S.Set Ident -> Expr              -> r+  , S.Set Ident -> Binder            -> r+  , S.Set Ident -> CaseAlternative   -> r+  , S.Set Ident -> DoNotationElement -> r)+everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)+  where+  -- Avoid importing Data.Monoid and getting shadowed names above+  (<>) = mappend++  f'' s a = f s a <> f' s a++  f' s (DataBindingGroupDeclaration ds) =+    let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))+    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+  f' s (ValueDeclaration name _ bs (Left gs)) =+    let s' = S.insert name s+        s'' = S.union s' (S.fromList (concatMap binderNames bs))+    in foldMap (h'' s') bs <> foldMap (\(grd, val) -> g'' s'' grd <> g'' s'' val) gs+  f' s (BindingGroupDeclaration ds) =+    let s' = S.union s (S.fromList (map (\(name, _, _) -> name) ds))+    in foldMap (\(_, _, val) -> g'' s' val) ds+  f' s (TypeClassDeclaration _ _ _ ds) = foldMap (f'' s) ds+  f' s (TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldMap (f'' s) ds+  f' s (PositionedDeclaration _ _ d) = f'' s d+  f' _ _ = mempty++  g'' s a = g s a <> g' s a++  g' s (UnaryMinus v1) = g'' s v1+  g' s (BinaryNoParens op v1 v2) = g' s op <> g' s v1 <> g' s v2+  g' s (Parens v1) = g'' s v1+  g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v+  g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v+  g' s (ArrayLiteral vs) = foldMap (g'' s) vs+  g' s (ObjectLiteral vs) = foldMap (g'' s . snd) vs+  g' s (ObjectConstructor vs) = foldMap (g'' s) (mapMaybe snd vs)+  g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1+  g' s (Accessor _ v1) = g'' s v1+  g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs+  g' s (ObjectUpdater obj vs) = foldMap (g'' s) obj <> foldMap (g'' s) (mapMaybe snd vs)+  g' s (Abs (Left name) v1) =+    let s' = S.insert name s+    in g'' s' v1+  g' s (Abs (Right b) v1) =+    let s' = S.union (S.fromList (binderNames b)) s+    in g'' s' v1+  g' s (App v1 v2) = g'' s v1 <> g'' s v2+  g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3+  g' s (Case vs alts) = foldMap (g'' s) vs <> foldMap (i'' s) alts+  g' s (TypedValue _ v1 _) = g'' s v1+  g' s (Let ds v1) =+    let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))+    in foldMap (f'' s') ds <> g'' s' v1+  g' s (Do es) = fold . snd . mapAccumL j'' s $ es+  g' s (PositionedValue _ _ v1) = g'' s v1+  g' _ _ = mempty++  h'' s a = h s a <> h' s a++  h' s (ConstructorBinder _ bs) = foldMap (h'' s) bs+  h' s (ObjectBinder bs) = foldMap (h'' s . snd) bs+  h' s (ArrayBinder bs) = foldMap (h'' s) bs+  h' s (NamedBinder name b1) =+    let s' = S.insert name s+    in h'' s' b1+  h' s (PositionedBinder _ _ b1) = h'' s b1+  h' s (TypedBinder _ b1) = h'' s b1+  h' _ _ = mempty++  i'' s a = i s a <> i' s a++  i' s (CaseAlternative bs (Right val)) =+    let s' = S.union s (S.fromList (concatMap binderNames bs))+    in foldMap (h'' s) bs <> g'' s' val+  i' s (CaseAlternative bs (Left gs)) =+    let s' = S.union s (S.fromList (concatMap binderNames bs))+    in foldMap (h'' s) bs <> foldMap (\(grd, val) -> g'' s' grd <> g'' s' val) gs++  j'' s a = let (s', r) = j' s a in (s', j s a <> r)++  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)+  j' s (DoNotationLet ds) =+    let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))+    in (s', foldMap (f'' s') ds)+  j' s (PositionedDoNotationElement _ _ e1) = j'' s e1++  getDeclIdent :: Declaration -> Maybe Ident+  getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d+  getDeclIdent (ValueDeclaration ident _ _ _) = Just ident+  getDeclIdent (TypeDeclaration ident _) = Just ident+  getDeclIdent _ = Nothing  accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r) accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)
src/Language/PureScript/Bundle.hs view
@@ -95,7 +95,7 @@ -- Each is labelled with the original AST node which generated it, so that we can dump it back -- into the output during codegen. data ModuleElement-  = Require JSNode String ModuleIdentifier+  = Require JSNode String (Either String ModuleIdentifier)   | Member JSNode Bool String [JSNode] [Key]   | ExportsList [(ExportType, String, JSNode, [Key])]   | Other JSNode@@ -137,13 +137,13 @@ node (NT n _ _) = n  -- | Calculate the ModuleIdentifier which a require(...) statement imports.-checkImportPath :: Maybe FilePath -> String -> ModuleIdentifier -> S.Set String -> Maybe ModuleIdentifier+checkImportPath :: Maybe FilePath -> String -> ModuleIdentifier -> S.Set String -> Either String ModuleIdentifier checkImportPath _ "./foreign" m _ =-  Just (ModuleIdentifier (moduleName m) Foreign)+  Right (ModuleIdentifier (moduleName m) Foreign) checkImportPath requirePath name _ names   | Just name' <- stripPrefix (fromMaybe "" requirePath) name-  , name' `S.member` names = Just (ModuleIdentifier name' Regular)-checkImportPath _ _ _ _ = Nothing+  , name' `S.member` names = Right (ModuleIdentifier name' Regular)+checkImportPath _ name _ _ = Left name  -- | Compute the dependencies of all elements in a module, and add them to the tree. --@@ -166,7 +166,7 @@   imports = mapMaybe toImport es     where     toImport :: ModuleElement -> Maybe (String, ModuleIdentifier)-    toImport (Require _ nm mid) = Just (nm, mid)+    toImport (Require _ nm (Right mid)) = Just (nm, mid)     toImport _ = Nothing    -- | Collects all member names in scope, so that we can identify dependencies of the second type.@@ -226,7 +226,7 @@     , JSIdentifier "require" <- node req     , JSArguments _ [ impS ] _ <- node impP     , JSStringLiteral _ importPath <- node impS-    , Just importPath' <- checkImportPath requirePath importPath mid mids+    , importPath' <- checkImportPath requirePath importPath mid mids     = pure (Require n importName importPath')   toModuleElement n     | JSVariables var [ varIntro ] _ <- node n@@ -371,7 +371,7 @@     return (m, mid, mapMaybe getKey els)    getKey :: ModuleElement -> Maybe ModuleIdentifier-  getKey (Require _ _ mi) = Just mi+  getKey (Require _ _ (Right mi)) = Just mi   getKey _ = Nothing  -- | A module is empty if it contains no exported members (in other words,@@ -416,9 +416,7 @@     declToJS (Require _ nm req) =       [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n  " ])                         [ NN (JSVarDecl (sp (JSIdentifier nm))-                                        [ sp (JSLiteral "=")-                                        , moduleReference sp (moduleName req)-                                        ])+                                        (sp (JSLiteral "=") : either require (return . moduleReference sp . moduleName) req))                         ]                         (nt (JSLiteral ";"))) ]     declToJS (ExportsList exps) = map toExport exps@@ -466,6 +464,11 @@                                                            (nt (JSLiteral ";")))     , lf     ]++  require :: String -> [JSNode]+  require mn = [ sp (JSIdentifier "require")+               , NN (JSArguments (nt (JSLiteral "(")) [ nt (JSStringLiteral '"' mn) ] (nt (JSLiteral ")")))+               ]    moduleReference :: (Node -> JSNode) -> String -> JSNode   moduleReference f mn =
src/Language/PureScript/CodeGen/JS.hs view
@@ -1,39 +1,29 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.CodeGen.JS--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- This module generates code in the simplified Javascript intermediate representation from Purescript code---------------------------------------------------------------------------------- {-# LANGUAGE GADTs #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} +-- |+-- This module generates code in the simplified Javascript intermediate representation from Purescript code+-- module Language.PureScript.CodeGen.JS   ( module AST   , module Common   , moduleToJs-  , mainCall   ) where  import Prelude () import Prelude.Compat  import Data.List ((\\), delete, intersect)-import Data.Maybe (isNothing)-import qualified Data.Traversable as T (traverse)+import Data.Maybe (isNothing, fromMaybe)+import qualified Data.Map as M+import qualified Data.Foldable as F+import qualified Data.Traversable as T  import Control.Arrow ((&&&))-import Control.Monad (replicateM, forM)+import Control.Monad (replicateM, forM, void)+import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Supply.Class @@ -43,6 +33,7 @@ import Language.PureScript.CodeGen.JS.Common as Common import Language.PureScript.CoreFn import Language.PureScript.Names+import Language.PureScript.Errors import Language.PureScript.CodeGen.JS.Optimizer import Language.PureScript.Options import Language.PureScript.Traversals (sndM)@@ -54,35 +45,97 @@ -- Generate code in the simplified Javascript intermediate representation for all declarations in a -- module. ---moduleToJs :: forall m. (Applicative m, Monad m, MonadReader Options m, MonadSupply m)-           => Module Ann -> Maybe JS -> m [JS]-moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = do-  jsImports <- T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps-  jsDecls <- mapM bindToJs decls-  optimized <- T.traverse (T.traverse optimize) jsDecls-  comments <- not <$> asks optionsNoComments-  let strict = JSStringLiteral "use strict"-  let header = if comments && not (null coms) then JSComment coms strict else strict-  let foreign' = [JSVariableIntroduction "$foreign" foreign_ | not $ null foreigns || isNothing foreign_]-  let moduleBody = header : foreign' ++ jsImports ++ concat optimized-  let foreignExps = exps `intersect` (fst `map` foreigns)-  let standardExps = exps \\ foreignExps-  let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) standardExps-                             ++ map (runIdent &&& foreignIdent) foreignExps-  return $ moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']+moduleToJs+  :: forall m+   . (Applicative m, Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)+  => Module Ann+  -> Maybe JS+  -> m [JS]+moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =+  rethrow (addHint (ErrorInModule mn)) $ do+    let usedNames = concatMap getNames decls+    let mnLookup = renameImports usedNames imps+    jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps+    let decls' = renameModules mnLookup decls+    jsDecls <- mapM bindToJs decls'+    optimized <- T.traverse (T.traverse optimize) jsDecls+    F.traverse_ (F.traverse_ checkIntegers) optimized+    comments <- not <$> asks optionsNoComments+    let strict = JSStringLiteral "use strict"+    let header = if comments && not (null coms) then JSComment coms strict else strict+    let foreign' = [JSVariableIntroduction "$foreign" foreign_ | not $ null foreigns || isNothing foreign_]+    let moduleBody = header : foreign' ++ jsImports ++ concat optimized+    let foreignExps = exps `intersect` (fst `map` foreigns)+    let standardExps = exps \\ foreignExps+    let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) standardExps+                               ++ map (runIdent &&& foreignIdent) foreignExps+    return $ moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']    where    -- |-  -- Generates Javascript code for a module import.+  -- Extracts all declaration names from a binding group.   ---  importToJs :: ModuleName -> m JS-  importToJs mn' = do+  getNames :: Bind Ann -> [Ident]+  getNames (NonRec ident _) = [ident]+  getNames (Rec vals) = map fst vals++  -- |+  -- Creates alternative names for each module to ensure they don't collide+  -- with declaration names.+  --+  renameImports :: [Ident] -> [ModuleName] -> M.Map ModuleName ModuleName+  renameImports ids mns = go M.empty ids mns+    where+    go :: M.Map ModuleName ModuleName -> [Ident] -> [ModuleName] -> M.Map ModuleName ModuleName+    go acc used (mn' : mns') =+      let mni = Ident $ runModuleName mn'+      in if mn' /= mn && mni `elem` used+         then let newName = freshModuleName 1 mn' used+              in go (M.insert mn' newName acc) (Ident (runModuleName newName) : used) mns'+         else go (M.insert mn' mn' acc) (mni : used) mns'+    go acc _ [] = acc++    freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName+    freshModuleName i mn'@(ModuleName pns) used =+      let newName = ModuleName $ init pns ++ [ProperName $ runProperName (last pns) ++ "_" ++ show i]+      in if Ident (runModuleName newName) `elem` used+         then freshModuleName (i + 1) mn' used+         else newName++  -- |+  -- Generates Javascript code for a module import, binding the required module+  -- to the alternative+  --+  importToJs :: M.Map ModuleName ModuleName -> ModuleName -> m JS+  importToJs mnLookup mn' = do     path <- asks optionsRequirePath+    let mnSafe = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup     let moduleBody = JSApp (JSVar "require") [JSStringLiteral (maybe id (</>) path $ runModuleName mn')]-    return $ JSVariableIntroduction (moduleNameToJs mn') (Just moduleBody)+    return $ JSVariableIntroduction (moduleNameToJs mnSafe) (Just moduleBody)    -- |+  -- Replaces the `ModuleName`s in the AST so that the generated code refers to+  -- the collision-avoiding renamed module imports.+  --+  renameModules :: M.Map ModuleName ModuleName -> [Bind Ann] -> [Bind Ann]+  renameModules mnLookup binds =+    let (f, _, _) = everywhereOnValues id goExpr goBinder+    in map f binds+    where+    goExpr :: Expr a -> Expr a+    goExpr (Var ann q) = Var ann (renameQual q)+    goExpr e = e+    goBinder :: Binder a -> Binder a+    goBinder (ConstructorBinder ann q1 q2 bs) = ConstructorBinder ann (renameQual q1) (renameQual q2) bs+    goBinder b = b+    renameQual :: Qualified a -> Qualified a+    renameQual (Qualified (Just mn') a) =+      let mnSafe = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup+      in Qualified (Just mnSafe) a+    renameQual q = q++  -- |   -- Generate code in the simplified Javascript intermediate representation for a declaration   --   bindToJs :: Bind Ann -> m [JS]@@ -120,6 +173,7 @@   accessor :: Ident -> JS -> JS   accessor (Ident prop) = accessorString prop   accessor (Op op) = JSIndexer (JSStringLiteral op)+  accessor (GenIdent _ _) = internalError "GenIdent in accessor"    accessorString :: String -> JS -> JS   accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)@@ -129,8 +183,8 @@   -- Generate code in the simplified Javascript intermediate representation for a value or expression.   --   valueToJs :: Expr Ann -> m JS-  valueToJs (Literal _ l) =-    literalToValueJS l+  valueToJs (Literal (pos, _, _, _) l) =+    maybe id rethrowWithPosition pos $ literalToValueJS l   valueToJs (Var (_, _, _, Just (IsConstructor _ [])) name) =     return $ JSAccessor "value" $ qualifiedToJS id name   valueToJs (Var (_, _, _, Just (IsConstructor _ _)) name) =@@ -207,7 +261,8 @@   iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []    literalToValueJS :: Literal (Expr Ann) -> m JS-  literalToValueJS (NumericLiteral n) = return $ JSNumericLiteral n+  literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral (Left i)+  literalToValueJS (NumericLiteral (Right n)) = return $ JSNumericLiteral (Right n)   literalToValueJS (StringLiteral s) = return $ JSStringLiteral s   literalToValueJS (CharLiteral c) = return $ JSStringLiteral [c]   literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral b@@ -275,10 +330,10 @@       go _ _ _ = internalError "Invalid arguments to bindersToJs"        failedPatternError :: [String] -> JS-      failedPatternError names = JSUnary JSNew $ JSApp (JSVar "Error") [JSBinary Add (JSStringLiteral errorMessage) (JSArrayLiteral $ zipWith valueError names vals)]+      failedPatternError names = JSUnary JSNew $ JSApp (JSVar "Error") [JSBinary Add (JSStringLiteral failedPatternMessage) (JSArrayLiteral $ zipWith valueError names vals)] -      errorMessage :: String-      errorMessage = "Failed pattern match" ++ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": "+      failedPatternMessage :: String+      failedPatternMessage = "Failed pattern match" ++ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": "        valueError :: String -> JS -> JS       valueError _ l@(JSNumericLiteral _) = l@@ -359,5 +414,22 @@       js <- binderToJs elVar done'' binder       return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js) -mainCall :: ModuleName -> String -> JS-mainCall mmi ns = JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar ns))) []+  -- Check that all integers fall within the valid int range for JavaScript.+  checkIntegers :: JS -> m ()+  checkIntegers = void . everywhereOnJSTopDownM go+    where+    go :: JS -> m JS+    go (JSUnary Negate (JSNumericLiteral (Left i))) =+      -- Move the negation inside the literal; since this is a top-down+      -- traversal doing this replacement will stop the next case from raising+      -- the error when attempting to use -2147483648, as if left unrewritten+      -- the value is `JSUnary Negate (JSNumericLiteral (Left 2147483648))`, and+      -- 2147483648 is larger than the maximum allowed int.+      return $ JSNumericLiteral (Left (-i))+    go js@(JSNumericLiteral (Left i)) =+      let minInt = -2147483648+          maxInt = 2147483647+      in if i < minInt || i > maxInt+         then throwError . errorMessage $ IntOutOfRange i "JavaScript" minInt maxInt+         else return js+    go other = return other
src/Language/PureScript/CodeGen/JS/AST.hs view
@@ -1,27 +1,12 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.CodeGen.JS.AST--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :--- -- | -- Data types for the intermediate simplified-Javascript AST ----------------------------------------------------------------------------------{-# LANGUAGE DeriveDataTypeable #-}- module Language.PureScript.CodeGen.JS.AST where  import Prelude () import Prelude.Compat  import Control.Monad.Identity-import Data.Data  import Language.PureScript.Comments import Language.PureScript.Traversals@@ -49,7 +34,8 @@   -- |   -- Constructor   ---  | JSNew deriving (Show, Read, Eq, Data, Typeable)+  | JSNew+  deriving (Show, Read, Eq)  -- | -- Built-in binary operators@@ -130,7 +116,8 @@   -- |   -- Bitwise right shift with zero-fill   ---  | ZeroFillShiftRight deriving (Show, Read, Eq, Data, Typeable)+  | ZeroFillShiftRight+  deriving (Show, Read, Eq)  -- | -- Data type for simplified Javascript expressions@@ -251,7 +238,8 @@   -- |   -- Commented Javascript   ---  | JSComment [Comment] JS deriving (Show, Read, Eq, Data, Typeable)+  | JSComment [Comment] JS+  deriving (Show, Read, Eq)  -- -- Traversals
src/Language/PureScript/CodeGen/JS/Common.hs view
@@ -1,25 +1,19 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.CodeGen.Common--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :--- -- | -- Common code generation utility functions --------------------------------------------------------------------------------- module Language.PureScript.CodeGen.JS.Common where  import Data.Char import Data.List (intercalate) +import Language.PureScript.Crash import Language.PureScript.Names +moduleNameToJs :: ModuleName -> String+moduleNameToJs (ModuleName pns) =+  let name = intercalate "_" (runProperName `map` pns)+  in if nameIsJsBuiltIn name then "$$" ++ name else name+ -- | -- Convert an Ident into a valid Javascript identifier: --@@ -30,9 +24,11 @@ --  * Symbols are prefixed with '$' followed by a symbol name or their ordinal value. -- identToJs :: Ident -> String-identToJs (Ident name) | nameIsJsReserved name = "$$" ++ name-identToJs (Ident name) = concatMap identCharToString name+identToJs (Ident name)+  | nameIsJsReserved name || nameIsJsBuiltIn name = "$$" ++ name+  | otherwise = concatMap identCharToString name identToJs (Op op) = concatMap identCharToString op+identToJs (GenIdent _ _) = internalError "GenIdent in identToJs"  -- | -- Test if a string is a valid JS identifier without escaping.@@ -75,107 +71,161 @@ -- nameIsJsReserved :: String -> Bool nameIsJsReserved name =-  name `elem` [ "abstract"-              , "arguments"-              , "boolean"-              , "break"-              , "byte"-              , "case"-              , "catch"-              , "char"-              , "class"-              , "const"-              , "continue"-              , "debugger"-              , "default"-              , "delete"-              , "do"-              , "double"-              , "else"-              , "enum"-              , "eval"-              , "export"-              , "extends"-              , "final"-              , "finally"-              , "float"-              , "for"-              , "function"-              , "goto"-              , "if"-              , "implements"-              , "import"-              , "in"-              , "instanceof"-              , "int"-              , "interface"-              , "let"-              , "long"-              , "native"-              , "new"-              , "null"-              , "package"-              , "private"-              , "protected"-              , "public"-              , "return"-              , "short"-              , "static"-              , "super"-              , "switch"-              , "synchronized"-              , "this"-              , "throw"-              , "throws"-              , "transient"-              , "try"-              , "typeof"-              , "var"-              , "void"-              , "volatile"-              , "while"-              , "with"-              , "yield" ] || properNameIsJsReserved name--moduleNameToJs :: ModuleName -> String-moduleNameToJs (ModuleName pns) =-  let name = intercalate "_" (runProperName `map` pns)-  in if properNameIsJsReserved name then "$$" ++ name else name+  name `elem` jsAnyReserved  -- |--- Checks whether a proper name is reserved in Javascript.+-- Checks whether a name matches a built-in value in Javascript. ---properNameIsJsReserved :: String -> Bool-properNameIsJsReserved name =-  name `elem` [ "Infinity"-              , "NaN"-              , "Object"-              , "Function"-              , "Boolean"-              , "Error"-              , "EvalError"-              , "InternalError"-              , "RangeError"-              , "ReferenceError"-              , "SyntaxError"-              , "TypeError"-              , "URIError"-              , "Number"-              , "Math"-              , "Date"-              , "String"-              , "RegExp"-              , "Array"-              , "Int8Array"-              , "Uint8Array"-              , "Uint8ClampedArray"-              , "Int16Array"-              , "Uint16Array"-              , "Int32Array"-              , "Uint32Array"-              , "Float32Array"-              , "Float64Array"-              , "ArrayBuffer"-              , "DataView"-              , "JSON"-              , "Intl" ]+nameIsJsBuiltIn :: String -> Bool+nameIsJsBuiltIn name =+  elem name+    [ "arguments"+    , "Array"+    , "ArrayBuffer"+    , "Boolean"+    , "DataView"+    , "Date"+    , "decodeURI"+    , "decodeURIComponent"+    , "encodeURI"+    , "encodeURIComponent"+    , "Error"+    , "escape"+    , "eval"+    , "EvalError"+    , "Float32Array"+    , "Float64Array"+    , "Function"+    , "Infinity"+    , "Int16Array"+    , "Int32Array"+    , "Int8Array"+    , "Intl"+    , "isFinite"+    , "isNaN"+    , "JSON"+    , "Map"+    , "Math"+    , "NaN"+    , "Number"+    , "Object"+    , "parseFloat"+    , "parseInt"+    , "Promise"+    , "Proxy"+    , "RangeError"+    , "ReferenceError"+    , "Reflect"+    , "RegExp"+    , "Set"+    , "SIMD"+    , "String"+    , "Symbol"+    , "SyntaxError"+    , "TypeError"+    , "Uint16Array"+    , "Uint32Array"+    , "Uint8Array"+    , "Uint8ClampedArray"+    , "undefined"+    , "unescape"+    , "URIError"+    , "WeakMap"+    , "WeakSet"+    ]++jsAnyReserved :: [String]+jsAnyReserved =+  concat+    [ jsKeywords+    , jsSometimesReserved+    , jsFutureReserved+    , jsFutureReservedStrict+    , jsOldReserved+    , jsLiterals+    ]++jsKeywords :: [String]+jsKeywords =+  [ "break"+  , "case"+  , "catch"+  , "class"+  , "const"+  , "continue"+  , "debugger"+  , "default"+  , "delete"+  , "do"+  , "else"+  , "export"+  , "extends"+  , "finally"+  , "for"+  , "function"+  , "if"+  , "import"+  , "in"+  , "instanceof"+  , "new"+  , "return"+  , "super"+  , "switch"+  , "this"+  , "throw"+  , "try"+  , "typeof"+  , "var"+  , "void"+  , "while"+  , "with"+  ]++jsSometimesReserved :: [String]+jsSometimesReserved =+  [ "await"+  , "let"+  , "static"+  , "yield"+  ]++jsFutureReserved :: [String]+jsFutureReserved =+  [ "enum" ]++jsFutureReservedStrict :: [String]+jsFutureReservedStrict =+  [ "implements"+  , "interface"+  , "package"+  , "private"+  , "protected"+  , "public"+  ]++jsOldReserved :: [String]+jsOldReserved =+  [ "abstract"+  , "boolean"+  , "byte"+  , "char"+  , "double"+  , "final"+  , "float"+  , "goto"+  , "int"+  , "long"+  , "native"+  , "short"+  , "synchronized"+  , "throws"+  , "transient"+  , "volatile"+  ]++jsLiterals :: [String]+jsLiterals =+  [ "null"+  , "true"+  , "false"+  ]
src/Language/PureScript/CodeGen/JS/Optimizer.hs view
@@ -1,13 +1,5 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.CodeGen.JS.Optimizer--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :---+{-# LANGUAGE FlexibleContexts #-}+ -- | -- This module optimizes code in the simplified-Javascript intermediate representation. --@@ -29,13 +21,7 @@ -- --  * Inlining primitive Javascript operators ----------------------------------------------------------------------------------{-# LANGUAGE FlexibleContexts #-}--module Language.PureScript.CodeGen.JS.Optimizer (-    optimize-) where+module Language.PureScript.CodeGen.JS.Optimizer (optimize) where  import Prelude () import Prelude.Compat@@ -65,11 +51,21 @@ optimize' :: (Monad m, MonadReader Options m, Applicative m, MonadSupply m) => JS -> m JS optimize' js = do   opts <- ask-  untilFixedPoint (inlineFnComposition . applyAll+  js' <- untilFixedPoint (inlineFnComposition . tidyUp . applyAll+    [ inlineCommonValues+    , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]+    , inlineOperator (C.dataFunction, C.apply) $ \f x -> JSApp f [x]+    , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]+    , inlineOperator (C.dataFunction, C.applyFlipped) $ \x f -> JSApp f [x]+    , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip JSIndexer+    , inlineCommonOperators+    ]) js+  untilFixedPoint (return . tidyUp) . tco opts . magicDo opts $ js'+  where+  tidyUp :: JS -> JS+  tidyUp = applyAll     [ collapseNestedBlocks     , collapseNestedIfs-    , tco opts-    , magicDo opts     , removeCodeAfterReturnStatements     , removeUnusedArg     , removeUndefinedApp@@ -77,11 +73,7 @@     , etaConvert     , evaluateIifes     , inlineVariables-    , inlineValues-    , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]-    , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]-    , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip JSIndexer-    , inlineCommonOperators ]) js+    ]  untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a untilFixedPoint f = go
src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs view
@@ -1,18 +1,6 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.CodeGen.JS.Optimizer.Common--- Copyright   :  (c) Phil Freeman 2013-14--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :--- -- | -- Common functions used by the various optimizer phases --------------------------------------------------------------------------------- module Language.PureScript.CodeGen.JS.Optimizer.Common where  import Data.Maybe (fromMaybe)@@ -76,3 +64,18 @@ removeFromBlock :: ([JS] -> [JS]) -> JS -> JS removeFromBlock go (JSBlock sts) = JSBlock (go sts) removeFromBlock _  js = js++isFn :: (String, String) -> JS -> Bool+isFn (moduleName, fnName) (JSAccessor x (JSVar y)) = x == fnName && y == moduleName+isFn (moduleName, fnName) (JSIndexer (JSStringLiteral x) (JSVar y)) = x == fnName && y == moduleName+isFn _ _ = False++isFn' :: [(String, String)] -> JS -> Bool+isFn' xs js = any (`isFn` js) xs++isDict :: (String, String) -> JS -> Bool+isDict (moduleName, dictName) (JSAccessor x (JSVar y)) = x == dictName && y == moduleName+isDict _ _ = False++isDict' :: [(String, String)] -> JS -> Bool+isDict' xs js = any (`isDict` js) xs
src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs view
@@ -1,28 +1,16 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.CodeGen.JS.Optimizer.Inliner--- Copyright   :  (c) Phil Freeman 2013-14--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :--- -- | -- This module provides basic inlining capabilities ----------------------------------------------------------------------------------module Language.PureScript.CodeGen.JS.Optimizer.Inliner (-  inlineVariables,-  inlineValues,-  inlineOperator,-  inlineCommonOperators,-  inlineFnComposition,-  etaConvert,-  unThunk,-  evaluateIifes-) where+module Language.PureScript.CodeGen.JS.Optimizer.Inliner+  ( inlineVariables+  , inlineCommonValues+  , inlineOperator+  , inlineCommonOperators+  , inlineFnComposition+  , etaConvert+  , unThunk+  , evaluateIifes+  ) where  import Prelude () import Prelude.Compat@@ -89,30 +77,30 @@       go (map (replaceIdent var js) sts)   go (s:sts) = s : go sts -inlineValues :: JS -> JS-inlineValues = everywhereOnJS convert+inlineCommonValues :: JS -> JS+inlineCommonValues = everywhereOnJS convert   where   convert :: JS -> JS-  convert (JSApp fn [dict]) | isDict semiringNumber dict && isFn fnZero fn = JSNumericLiteral (Left 0)-                            | isDict semiringNumber dict && isFn fnOne fn = JSNumericLiteral (Left 1)-                            | isDict semiringInt dict && isFn fnZero fn = JSNumericLiteral (Left 0)-                            | isDict semiringInt dict && isFn fnOne fn = JSNumericLiteral (Left 1)-                            | isDict boundedBoolean dict && isFn fnBottom fn = JSBooleanLiteral False-                            | isDict boundedBoolean dict && isFn fnTop fn = JSBooleanLiteral True+  convert (JSApp fn [dict])+    | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnZero fn = JSNumericLiteral (Left 0)+    | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnOne fn = JSNumericLiteral (Left 1)+    | isDict' boundedBoolean dict && isFn' fnBottom fn = JSBooleanLiteral False+    | isDict' boundedBoolean dict && isFn' fnTop fn = JSBooleanLiteral True   convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y])-    | isDict semiringInt dict && isFn fnAdd fn = JSBinary BitwiseOr (JSBinary Add x y) (JSNumericLiteral (Left 0))-    | isDict semiringInt dict && isFn fnMultiply fn = JSBinary BitwiseOr (JSBinary Multiply x y) (JSNumericLiteral (Left 0))-    | isDict moduloSemiringInt dict && isFn fnDivide fn = JSBinary BitwiseOr (JSBinary Divide x y) (JSNumericLiteral (Left 0))-    | isDict ringInt dict && isFn fnSubtract fn = JSBinary BitwiseOr (JSBinary Subtract x y) (JSNumericLiteral (Left 0))+    | isDict' semiringInt dict && isFn' fnAdd fn = intOp Add x y+    | isDict' semiringInt dict && isFn' fnMultiply fn = intOp Multiply x y+    | isDict' moduloSemiringInt dict && isFn' fnDivide fn = intOp Divide x y+    | isDict' ringInt dict && isFn' fnSubtract fn = intOp Subtract x y   convert other = other-  fnZero = (C.prelude, C.zero)-  fnOne = (C.prelude, C.one)-  fnBottom = (C.prelude, C.bottom)-  fnTop = (C.prelude, C.top)-  fnAdd = (C.prelude, (C.+))-  fnDivide = (C.prelude, (C./))-  fnMultiply = (C.prelude, (C.*))-  fnSubtract = (C.prelude, (C.-))+  fnZero = [(C.prelude, C.zero), (C.dataSemiring, C.zero)]+  fnOne = [(C.prelude, C.one), (C.dataSemiring, C.one)]+  fnBottom = [(C.prelude, C.bottom), (C.dataBounded, C.bottom)]+  fnTop = [(C.prelude, C.top), (C.dataBounded, C.top)]+  fnAdd = [(C.prelude, (C.+)), (C.prelude, (C.add)), (C.dataSemiring, (C.+)), (C.dataSemiring, (C.add))]+  fnDivide = [(C.prelude, (C./)), (C.prelude, (C.div)), (C.dataModuloSemiring, C.div)]+  fnMultiply = [(C.prelude, (C.*)), (C.prelude, (C.mul)), (C.dataSemiring, (C.*)), (C.dataSemiring, (C.mul))]+  fnSubtract = [(C.prelude, (C.-)), (C.prelude, C.sub), (C.dataRing, C.sub)]+  intOp op x y = JSBinary BitwiseOr (JSBinary op x y) (JSNumericLiteral (Left 0))  inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS inlineOperator (m, op) f = everywhereOnJS convert@@ -126,43 +114,54 @@  inlineCommonOperators :: JS -> JS inlineCommonOperators = applyAll $-  [ binary semiringNumber (C.+) Add-  , binary semiringNumber (C.*) Multiply+  [ binary semiringNumber opAdd Add+  , binary semiringNumber opMul Multiply -  , binary ringNumber (C.-) Subtract-  , unary  ringNumber C.negate Negate-  , binary ringInt (C.-) Subtract-  , unary  ringInt C.negate Negate+  , binary ringNumber opSub Subtract+  , unary  ringNumber opNegate Negate+  , binary ringInt opSub Subtract+  , unary  ringInt opNegate Negate -  , binary moduloSemiringNumber (C./) Divide-  , binary moduloSemiringInt C.mod Modulus+  , binary moduloSemiringNumber opDiv Divide+  , binary moduloSemiringInt opMod Modulus -  , binary eqNumber (C.==) EqualTo-  , binary eqNumber (C./=) NotEqualTo-  , binary eqInt (C.==) EqualTo-  , binary eqInt (C./=) NotEqualTo-  , binary eqString (C.==) EqualTo-  , binary eqString (C./=) NotEqualTo-  , binary eqBoolean (C.==) EqualTo-  , binary eqBoolean (C./=) NotEqualTo+  , binary eqNumber opEq EqualTo+  , binary eqNumber opNotEq NotEqualTo+  , binary eqInt opEq EqualTo+  , binary eqInt opNotEq NotEqualTo+  , binary eqString opEq EqualTo+  , binary eqString opNotEq NotEqualTo+  , binary eqChar opEq EqualTo+  , binary eqChar opNotEq NotEqualTo+  , binary eqBoolean opEq EqualTo+  , binary eqBoolean opNotEq NotEqualTo -  , binary ordNumber (C.<) LessThan-  , binary ordNumber (C.>) GreaterThan-  , binary ordNumber (C.<=) LessThanOrEqualTo-  , binary ordNumber (C.>=) GreaterThanOrEqualTo-  , binary ordInt (C.<) LessThan-  , binary ordInt (C.>) GreaterThan-  , binary ordInt (C.<=) LessThanOrEqualTo-  , binary ordInt (C.>=) GreaterThanOrEqualTo+  , binary ordBoolean opLessThan LessThan+  , binary ordBoolean opLessThanOrEq LessThanOrEqualTo+  , binary ordBoolean opGreaterThan GreaterThan+  , binary ordBoolean opGreaterThanOrEq GreaterThanOrEqualTo+  , binary ordChar opLessThan LessThan+  , binary ordChar opLessThanOrEq LessThanOrEqualTo+  , binary ordChar opGreaterThan GreaterThan+  , binary ordChar opGreaterThanOrEq GreaterThanOrEqualTo+  , binary ordInt opLessThan LessThan+  , binary ordInt opLessThanOrEq LessThanOrEqualTo+  , binary ordInt opGreaterThan GreaterThan+  , binary ordInt opGreaterThanOrEq GreaterThanOrEqualTo+  , binary ordNumber opLessThan LessThan+  , binary ordNumber opLessThanOrEq LessThanOrEqualTo+  , binary ordNumber opGreaterThan GreaterThan+  , binary ordNumber opGreaterThanOrEq GreaterThanOrEqualTo+  , binary ordString opLessThan LessThan+  , binary ordString opLessThanOrEq LessThanOrEqualTo+  , binary ordString opGreaterThan GreaterThan+  , binary ordString opGreaterThanOrEq GreaterThanOrEqualTo -  , binary semigroupString (C.<>) Add-  , binary semigroupString (C.++) Add+  , binary semigroupString opAppend Add -  , binary booleanAlgebraBoolean (C.&&) And-  , binary booleanAlgebraBoolean (C.||) Or-  , binaryFunction booleanAlgebraBoolean C.conj And-  , binaryFunction booleanAlgebraBoolean C.disj Or-  , unary booleanAlgebraBoolean C.not Not+  , binary booleanAlgebraBoolean opConj And+  , binary booleanAlgebraBoolean opDisj Or+  , unary  booleanAlgebraBoolean opNot Not    , binary' C.dataIntBits (C..|.) BitwiseOr   , binary' C.dataIntBits (C..&.) BitwiseAnd@@ -174,11 +173,11 @@   ] ++   [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]   where-  binary :: (String, String) -> String -> BinaryOperator -> JS -> JS-  binary dict opString op = everywhereOnJS convert+  binary :: [(String, String)] -> [(String, String)] -> BinaryOperator -> JS -> JS+  binary dict fns op = everywhereOnJS convert     where     convert :: JS -> JS-    convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isDict dict dict' && isPreludeFn opString fn = JSBinary op x y+    convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isDict' dict dict' && isFn' fns fn = JSBinary op x y     convert other = other   binary' :: String -> String -> BinaryOperator -> JS -> JS   binary' moduleName opString op = everywhereOnJS convert@@ -186,17 +185,11 @@     convert :: JS -> JS     convert (JSApp (JSApp fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary op x y     convert other = other-  binaryFunction :: (String, String) -> String -> BinaryOperator -> JS -> JS-  binaryFunction dict fnName op = everywhereOnJS convert-    where-    convert :: JS -> JS-    convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isPreludeFn fnName fn && isDict dict dict' = JSBinary op x y-    convert other = other-  unary :: (String, String) -> String -> UnaryOperator -> JS -> JS-  unary dict fnName op = everywhereOnJS convert+  unary :: [(String, String)] -> [(String, String)] -> UnaryOperator -> JS -> JS+  unary dicts fns op = everywhereOnJS convert     where     convert :: JS -> JS-    convert (JSApp (JSApp fn [dict']) [x]) | isPreludeFn fnName fn && isDict dict dict' = JSUnary op x+    convert (JSApp (JSApp fn [dict']) [x]) | isDict' dicts dict' && isFn' fns fn = JSUnary op x     convert other = other   unary' :: String -> String -> UnaryOperator -> JS -> JS   unary' moduleName fnName op = everywhereOnJS convert@@ -246,71 +239,130 @@ inlineFnComposition = everywhereOnJSTopDownM convert   where   convert :: (MonadSupply m) => JS -> m JS-  convert (JSApp (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) [z]) | isFnCompose dict' fn =-    return $ JSApp x [JSApp y [z]]-  convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isFnCompose dict' fn = do-    arg <- freshName-    return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp x [JSApp y [JSVar arg]]])+  convert (JSApp (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) [z])+    | isFnCompose dict' fn = return $ JSApp x [JSApp y [z]]+    | isFnComposeFlipped dict' fn = return $ JSApp y [JSApp x [z]]+  convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y])+    | isFnCompose dict' fn = do+        arg <- freshName+        return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp x [JSApp y [JSVar arg]]])+    | isFnComposeFlipped dict' fn = do+        arg <- freshName+        return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp y [JSApp x [JSVar arg]]])   convert other = return other   isFnCompose :: JS -> JS -> Bool-  isFnCompose dict' fn = isDict semigroupoidFn dict' && (isPreludeFn (C.<<<) fn || isPreludeFn C.compose fn)+  isFnCompose dict' fn = isDict' semigroupoidFn dict' && isFn' fnCompose fn+  isFnComposeFlipped :: JS -> JS -> Bool+  isFnComposeFlipped dict' fn = isDict' semigroupoidFn dict' && isFn' fnComposeFlipped fn+  fnCompose :: [(String, String)]+  fnCompose = [(C.prelude, C.compose), (C.prelude, (C.<<<)), (C.controlSemigroupoid, C.compose)]+  fnComposeFlipped :: [(String, String)]+  fnComposeFlipped = [(C.prelude, (C.>>>)), (C.controlSemigroupoid, C.composeFlipped)] -isDict :: (String, String) -> JS -> Bool-isDict (moduleName, dictName) (JSAccessor x (JSVar y)) = x == dictName && y == moduleName-isDict _ _ = False+semiringNumber :: [(String, String)]+semiringNumber = [(C.prelude, C.semiringNumber), (C.dataSemiring, C.semiringNumber)] -isFn :: (String, String) -> JS -> Bool-isFn (moduleName, fnName) (JSAccessor x (JSVar y)) = x == fnName && y == moduleName-isFn (moduleName, fnName) (JSIndexer (JSStringLiteral x) (JSVar y)) = x == fnName && y == moduleName-isFn _ _ = False+semiringInt :: [(String, String)]+semiringInt = [(C.prelude, C.semiringInt), (C.dataSemiring, C.semiringInt)] -isPreludeFn :: String -> JS -> Bool-isPreludeFn fnName = isFn (C.prelude, fnName)+ringNumber :: [(String, String)]+ringNumber = [(C.prelude, C.ringNumber), (C.dataRing, C.ringNumber)] -semiringNumber :: (String, String)-semiringNumber = (C.prelude, C.semiringNumber)+ringInt :: [(String, String)]+ringInt = [(C.prelude, C.ringInt), (C.dataRing, C.ringInt)] -semiringInt :: (String, String)-semiringInt = (C.prelude, C.semiringInt)+moduloSemiringNumber :: [(String, String)]+moduloSemiringNumber = [(C.prelude, C.moduloSemiringNumber), (C.dataModuloSemiring, C.moduloSemiringNumber)] -ringNumber :: (String, String)-ringNumber = (C.prelude, C.ringNumber)+moduloSemiringInt :: [(String, String)]+moduloSemiringInt = [(C.prelude, C.moduloSemiringInt), (C.dataModuloSemiring, C.moduloSemiringInt)] -ringInt :: (String, String)-ringInt = (C.prelude, C.ringInt)+eqNumber :: [(String, String)]+eqNumber = [(C.prelude, C.eqNumber), (C.dataEq, C.eqNumber)] -moduloSemiringNumber :: (String, String)-moduloSemiringNumber = (C.prelude, C.moduloSemiringNumber)+eqInt :: [(String, String)]+eqInt = [(C.prelude, C.eqInt), (C.dataEq, C.eqInt)] -moduloSemiringInt :: (String, String)-moduloSemiringInt = (C.prelude, C.moduloSemiringInt)+eqString :: [(String, String)]+eqString = [(C.prelude, C.eqString), (C.dataEq, C.eqString)] -eqNumber :: (String, String)-eqNumber = (C.prelude, C.eqNumber)+eqChar :: [(String, String)]+eqChar = [(C.prelude, C.eqChar), (C.dataEq, C.eqChar)] -eqInt :: (String, String)-eqInt = (C.prelude, C.eqInt)+eqBoolean :: [(String, String)]+eqBoolean = [(C.prelude, C.eqBoolean), (C.dataEq, C.eqBoolean)] -eqString :: (String, String)-eqString = (C.prelude, C.eqNumber)+ordBoolean :: [(String, String)]+ordBoolean = [(C.prelude, C.ordBoolean), (C.dataOrd, C.ordBoolean)] -eqBoolean :: (String, String)-eqBoolean = (C.prelude, C.eqNumber)+ordNumber :: [(String, String)]+ordNumber = [(C.prelude, C.ordNumber), (C.dataOrd, C.ordNumber)] -ordNumber :: (String, String)-ordNumber = (C.prelude, C.ordNumber)+ordInt :: [(String, String)]+ordInt = [(C.prelude, C.ordInt), (C.dataOrd, C.ordInt)] -ordInt :: (String, String)-ordInt = (C.prelude, C.ordInt)+ordString :: [(String, String)]+ordString = [(C.prelude, C.ordString), (C.dataOrd, C.ordString)] -semigroupString :: (String, String)-semigroupString = (C.prelude, C.semigroupString)+ordChar :: [(String, String)]+ordChar = [(C.prelude, C.ordChar), (C.dataOrd, C.ordChar)] -boundedBoolean :: (String, String)-boundedBoolean = (C.prelude, C.boundedBoolean)+semigroupString :: [(String, String)]+semigroupString = [(C.prelude, C.semigroupString), (C.dataSemigroup, C.semigroupString)] -booleanAlgebraBoolean :: (String, String)-booleanAlgebraBoolean = (C.prelude, C.booleanAlgebraBoolean)+boundedBoolean :: [(String, String)]+boundedBoolean = [(C.prelude, C.boundedBoolean), (C.dataBounded, C.boundedBoolean)] -semigroupoidFn :: (String, String)-semigroupoidFn = (C.prelude, C.semigroupoidFn)+booleanAlgebraBoolean :: [(String, String)]+booleanAlgebraBoolean = [(C.prelude, C.booleanAlgebraBoolean), (C.dataBooleanAlgebra, C.booleanAlgebraBoolean)]++semigroupoidFn :: [(String, String)]+semigroupoidFn = [(C.prelude, C.semigroupoidFn), (C.controlSemigroupoid, C.semigroupoidFn)]++opAdd :: [(String, String)]+opAdd = [(C.prelude, (C.+)), (C.prelude, C.add), (C.dataSemiring, C.add)]++opMul :: [(String, String)]+opMul = [(C.prelude, (C.*)), (C.prelude, C.mul), (C.dataSemiring, C.mul)]++opEq :: [(String, String)]+opEq = [(C.prelude, (C.==)), (C.prelude, C.eq), (C.dataEq, C.eq)]++opNotEq :: [(String, String)]+opNotEq = [(C.prelude, (C./=)), (C.dataEq, C.notEq)]++opLessThan :: [(String, String)]+opLessThan = [(C.prelude, (C.<)), (C.dataOrd, C.lessThan)]++opLessThanOrEq :: [(String, String)]+opLessThanOrEq = [(C.prelude, (C.<=)), (C.dataOrd, C.lessThanOrEq)]++opGreaterThan :: [(String, String)]+opGreaterThan = [(C.prelude, (C.>)), (C.dataOrd, C.greaterThan)]++opGreaterThanOrEq :: [(String, String)]+opGreaterThanOrEq = [(C.prelude, (C.>=)), (C.dataOrd, C.greaterThanOrEq)]++opAppend :: [(String, String)]+opAppend = [(C.prelude, (C.<>)), (C.prelude, (C.++)), (C.prelude, C.append), (C.dataSemigroup, C.append)]++opSub :: [(String, String)]+opSub = [(C.prelude, (C.-)), (C.prelude, C.sub), (C.dataRing, C.sub)]++opNegate :: [(String, String)]+opNegate = [(C.prelude, C.negate), (C.dataRing, C.negate)]++opDiv :: [(String, String)]+opDiv = [(C.prelude, (C./)), (C.prelude, C.div), (C.dataModuloSemiring, C.div)]++opMod :: [(String, String)]+opMod = [(C.prelude, C.mod), (C.dataModuloSemiring, C.mod)]++opConj :: [(String, String)]+opConj = [(C.prelude, (C.&&)), (C.prelude, C.conj), (C.dataBooleanAlgebra, C.conj)]++opDisj :: [(String, String)]+opDisj = [(C.prelude, (C.||)), (C.prelude, C.disj), (C.dataBooleanAlgebra, C.disj)]++opNot :: [(String, String)]+opNot = [(C.prelude, C.not), (C.dataBooleanAlgebra, C.not)]
src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs view
@@ -1,29 +1,14 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.CodeGen.JS.Optimizer.MagicDo--- Copyright   :  (c) Phil Freeman 2013-14--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :--- -- | -- This module implements the "Magic Do" optimization, which inlines calls to return -- and bind for the Eff monad, as well as some of its actions. ----------------------------------------------------------------------------------module Language.PureScript.CodeGen.JS.Optimizer.MagicDo (-  magicDo-) where+module Language.PureScript.CodeGen.JS.Optimizer.MagicDo (magicDo) where  import Data.List (nub) import Data.Maybe (fromJust, isJust)  import Language.PureScript.CodeGen.JS.AST-import Language.PureScript.CodeGen.JS.Common-import Language.PureScript.Names+import Language.PureScript.CodeGen.JS.Optimizer.Common import Language.PureScript.Options import qualified Language.PureScript.Constants as C @@ -54,9 +39,7 @@   fnName = "__do"   -- Desugar monomorphic calls to >>= and return for the Eff monad   convert :: JS -> JS-  -- Desugar return-  convert (JSApp (JSApp ret [val]) []) | isReturn ret = val-  -- Desugar pure+  -- Desugar pure & return   convert (JSApp (JSApp pure' [val]) []) | isPure pure' = val   -- Desugar >>   convert (JSApp (JSApp bind [m]) [JSFunction Nothing [] (JSBlock js)]) | isBind bind =@@ -72,33 +55,19 @@     JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn $ JSObjectLiteral []])) []   convert other = other   -- Check if an expression represents a monomorphic call to >>= for the Eff monad-  isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict C.bindEffDictionary effDict = True+  isBind (JSApp fn [dict]) | isDict (C.eff, C.bindEffDictionary) dict && isBindPoly fn = True   isBind _ = False-  -- Check if an expression represents a monomorphic call to return for the Eff monad-  isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict C.monadEffDictionary effDict = True-  isReturn _ = False-  -- Check if an expression represents a monomorphic call to pure for the Eff applicative-  isPure (JSApp purePoly [effDict]) | isPurePoly purePoly && isEffDict C.applicativeEffDictionary effDict = True+  -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative+  isPure (JSApp fn [dict]) | isDict (C.eff, C.applicativeEffDictionary) dict && isPurePoly fn = True   isPure _ = False   -- Check if an expression represents the polymorphic >>= function-  isBindPoly (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && (prop `elem` map identToJs [Ident C.bind, Op (C.>>=)])-  isBindPoly (JSIndexer (JSStringLiteral bind) (JSVar prelude)) = prelude == C.prelude && (bind `elem` [C.bind, (C.>>=)])-  isBindPoly _ = False-  -- Check if an expression represents the polymorphic return function-  isRetPoly (JSAccessor returnEscaped (JSVar prelude)) = prelude == C.prelude && returnEscaped == C.returnEscaped-  isRetPoly (JSIndexer (JSStringLiteral return') (JSVar prelude)) = prelude == C.prelude && return' == C.return-  isRetPoly _ = False-  -- Check if an expression represents the polymorphic pure function-  isPurePoly (JSAccessor pure' (JSVar prelude)) = prelude == C.prelude && pure' == C.pure'-  isPurePoly (JSIndexer (JSStringLiteral pure') (JSVar prelude)) = prelude == C.prelude && pure' == C.pure'-  isPurePoly _ = False-  -- Check if an expression represents a function in the Ef module+  isBindPoly = isFn' [(C.prelude, C.bind), (C.prelude, (C.>>=)), (C.controlBind, C.bind)]+  -- Check if an expression represents the polymorphic pure or return function+  isPurePoly = isFn' [(C.prelude, C.pure'), (C.prelude, C.return), (C.controlApplicative, C.pure')]+  -- Check if an expression represents a function in the Eff module   isEffFunc name (JSAccessor name' (JSVar eff)) = eff == C.eff && name == name'   isEffFunc _ _ = False-  -- Check if an expression represents the Monad Eff dictionary-  isEffDict name (JSVar ident) | ident == name = True-  isEffDict name (JSAccessor prop (JSVar eff)) = eff == C.eff && prop == name-  isEffDict _ _ = False+   -- Remove __do function applications which remain after desugaring   undo :: JS -> JS   undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
src/Language/PureScript/Comments.hs view
@@ -1,29 +1,15 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Parser.Comments--- Copyright   :  (c) Phil Freeman 2015--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :---+{-# LANGUAGE TemplateHaskell #-}+ -- | -- Defines the types of source code comments ----------------------------------------------------------------------------------{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE TemplateHaskell #-}- module Language.PureScript.Comments where  import Data.Aeson.TH-import qualified Data.Data as D  data Comment   = LineComment String   | BlockComment String-  deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)+  deriving (Show, Read, Eq, Ord)  $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Comment)
src/Language/PureScript/Constants.hs view
@@ -1,18 +1,6 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Constants--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :--- -- | -- Various constants which refer to things in the Prelude --------------------------------------------------------------------------------- module Language.PureScript.Constants where  -- Operators@@ -20,59 +8,107 @@ ($) :: String ($) = "$" +apply :: String+apply = "apply"+ (#) :: String (#) = "#" +applyFlipped :: String+applyFlipped = "applyFlipped"+ (<>) :: String (<>) = "<>"  (++) :: String (++) = "++" +append :: String+append = "append"+ (>>=) :: String (>>=) = ">>=" +bind :: String+bind = "bind"+ (+) :: String (+) = "+" +add :: String+add = "add"+ (-) :: String (-) = "-" +sub :: String+sub = "sub"+ (*) :: String (*) = "*" +mul :: String+mul = "mul"+ (/) :: String (/) = "/" +div :: String+div = "div"+ (%) :: String (%) = "%" +mod :: String+mod = "mod"+ (<) :: String (<) = "<" +lessThan :: String+lessThan = "lessThan"+ (>) :: String (>) = ">" +greaterThan :: String+greaterThan = "greaterThan"+ (<=) :: String (<=) = "<=" +lessThanOrEq :: String+lessThanOrEq = "lessThanOrEq"+ (>=) :: String (>=) = ">=" +greaterThanOrEq :: String+greaterThanOrEq = "greaterThanOrEq"+ (==) :: String (==) = "==" +eq :: String+eq = "eq"+ (/=) :: String (/=) = "/=" +notEq :: String+notEq = "notEq"+ (&&) :: String (&&) = "&&" +conj :: String+conj = "conj"+ (||) :: String (||) = "||" -bind :: String-bind = "bind"+disj :: String+disj = "disj"  unsafeIndex :: String unsafeIndex = "unsafeIndex"@@ -92,6 +128,12 @@ compose :: String compose = "compose" +(>>>) :: String+(>>>) = ">>>"++composeFlipped :: String+composeFlipped = "composeFlipped"+ -- Functions  negate :: String@@ -100,15 +142,6 @@ not :: String not = "not" -conj :: String-conj = "conj"--disj :: String-disj = "disj"--mod :: String-mod = "mod"- shl :: String shl = "shl" @@ -211,12 +244,21 @@ moduloSemiringInt :: String moduloSemiringInt = "moduloSemiringInt" +ordBoolean :: String+ordBoolean = "ordBoolean"+ ordNumber :: String ordNumber = "ordNumber"  ordInt :: String ordInt = "ordInt" +ordString :: String+ordString = "ordString"++ordChar :: String+ordChar = "ordChar"+ eqNumber :: String eqNumber = "eqNumber" @@ -226,6 +268,9 @@ eqString :: String eqString = "eqString" +eqChar :: String+eqChar = "eqChar"+ eqBoolean :: String eqBoolean = "eqBoolean" @@ -284,6 +329,39 @@  st :: String st = "Control_Monad_ST"++controlApplicative :: String+controlApplicative = "Control_Applicative"++controlSemigroupoid :: String+controlSemigroupoid = "Control_Semigroupoid"++controlBind :: String+controlBind = "Control_Bind"++dataBounded :: String+dataBounded = "Data_Bounded"++dataSemigroup :: String+dataSemigroup = "Data_Semigroup"++dataModuloSemiring :: String+dataModuloSemiring = "Data_ModuloSemiring"++dataBooleanAlgebra :: String+dataBooleanAlgebra = "Data_BooleanAlgebra"++dataEq :: String+dataEq = "Data_Eq"++dataOrd :: String+dataOrd = "Data_Ord"++dataSemiring :: String+dataSemiring = "Data_Semiring"++dataRing :: String+dataRing = "Data_Ring"  dataFunction :: String dataFunction = "Data_Function"
src/Language/PureScript/CoreFn/Binders.hs view
@@ -1,24 +1,10 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.CoreFn.Binders--- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>--- Stability   :  experimental--- Portability :------ | The core functional representation for binders-----------------------------------------------------------------------------------{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} +-- |+-- The core functional representation for binders+-- module Language.PureScript.CoreFn.Binders where -import qualified Data.Data as D- import Language.PureScript.CoreFn.Literals import Language.PureScript.Names @@ -39,10 +25,11 @@   --   | VarBinder a Ident   -- |-  -- A binder which matches a data constructor (type name, constructor name, binders)+  -- A binder which matches a data constructor   ---  | ConstructorBinder a (Qualified ProperName) (Qualified ProperName) [Binder a]+  | ConstructorBinder a (Qualified (ProperName 'TypeName)) (Qualified (ProperName 'ConstructorName)) [Binder a]   -- |   -- A binder which binds its input to an identifier   ---  | NamedBinder a Ident (Binder a) deriving (Show, Read, D.Data, D.Typeable, Functor)+  | NamedBinder a Ident (Binder a)+  deriving (Show, Read, Functor)
src/Language/PureScript/CoreFn/Desugar.hs view
@@ -1,17 +1,3 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.CoreFn.Desugar--- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess--- License     :  MIT (http://opensource.org/licenses/MIT)------ Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>--- Stability   :  experimental--- Portability :------ | The AST -> CoreFn desugaring step---------------------------------------------------------------------------------- module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where  import Data.Function (on)@@ -68,6 +54,8 @@   declToCoreFn ss _   (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds   declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) =     [NonRec name (exprToCoreFn ss com Nothing e)]+  declToCoreFn ss com (A.FixityDeclaration _ name (Just alias)) =+    [NonRec (Op name) (Var (ss, com, Nothing, getValueMeta alias) alias)]   declToCoreFn ss _   (A.BindingGroupDeclaration ds) =     [Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds]   declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =@@ -182,7 +170,7 @@   -- |   -- Gets metadata for data constructors.   ---  getConstructorMeta :: Qualified ProperName -> Meta+  getConstructorMeta :: Qualified (ProperName 'ConstructorName) -> Meta   getConstructorMeta ctor =     case lookupConstructor env ctor of       (Newtype, _, _, _) -> IsNewtype@@ -190,9 +178,15 @@         let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType         in IsConstructor constructorType fields     where-    numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> Int++    numConstructors+      :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, Type, [Ident]))+      -> Int     numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env-    typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> (ModuleName, ProperName)++    typeConstructor+      :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, Type, [Ident]))+      -> (ModuleName, ProperName 'TypeName)     typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor)     typeConstructor _ = internalError "Invalid argument to typeConstructor" @@ -203,9 +197,14 @@ -- findQualModules :: [A.Declaration] -> [ModuleName] findQualModules decls =-  let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues fqBinders (const []) (const [])+  let (f, _, _, _, _) = everythingOnValues (++) fqDecls fqValues fqBinders (const []) (const [])   in f `concatMap` decls   where+  fqDecls :: A.Declaration -> [ModuleName]+  fqDecls (A.TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) = [mn]+  fqDecls (A.FixityDeclaration _ _ (Just (Qualified (Just mn) _))) = [mn]+  fqDecls _ = []+   fqValues :: A.Expr -> [ModuleName]   fqValues (A.Var (Qualified (Just mn) _)) = [mn]   fqValues (A.Constructor (Qualified (Just mn) _)) = [mn]@@ -219,7 +218,7 @@ -- Desugars import declarations from AST to CoreFn representation. -- importToCoreFn :: A.Declaration -> Maybe ModuleName-importToCoreFn (A.ImportDeclaration name _ _) = Just name+importToCoreFn (A.ImportDeclaration name _ _ _) = Just name importToCoreFn (A.PositionedDeclaration _ _ d) = importToCoreFn d importToCoreFn _ = Nothing @@ -262,5 +261,5 @@ -- | -- Converts a ProperName to an Ident. ---properToIdent :: ProperName -> Ident+properToIdent :: ProperName a -> Ident properToIdent = Ident . runProperName
src/Language/PureScript/CoreFn/Expr.hs view
@@ -1,26 +1,12 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.CoreFn.Expr--- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>--- Stability   :  experimental--- Portability :------ | The core functional representation-----------------------------------------------------------------------------------{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} +-- |+-- The core functional representation+-- module Language.PureScript.CoreFn.Expr where  import Control.Arrow ((***)) -import qualified Data.Data as D- import Language.PureScript.CoreFn.Binders import Language.PureScript.CoreFn.Literals import Language.PureScript.Names@@ -36,7 +22,7 @@   -- |   -- A data constructor (type name, constructor name, field names)   ---  | Constructor a ProperName ProperName [Ident]+  | Constructor a (ProperName 'TypeName) (ProperName 'ConstructorName) [Ident]   -- |   -- A record property accessor   --@@ -64,7 +50,8 @@   -- |   -- A let binding   ---  | Let a [Bind a] (Expr a) deriving (Show, Read, D.Data, D.Typeable, Functor)+  | Let a [Bind a] (Expr a)+  deriving (Show, Read, Functor)  -- | -- A let or module binding.@@ -77,7 +64,8 @@   -- |   -- Mutually recursive binding group for several values   ---  | Rec [(Ident, Expr a)] deriving (Show, Read, D.Data, D.Typeable, Functor)+  | Rec [(Ident, Expr a)]+  deriving (Show, Read, Functor)  -- | -- A guard is just a boolean-valued expression that appears alongside a set of binders@@ -96,7 +84,8 @@     -- The result expression or a collect of guarded expressions     --   , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)-  } deriving (Show, Read, D.Data, D.Typeable)+  }+  deriving (Show, Read)  instance Functor CaseAlternative where
src/Language/PureScript/CoreFn/Literals.hs view
@@ -1,24 +1,10 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.CoreFn.Literals--- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>--- Stability   :  experimental--- Portability :------ | The core functional representation for literal values.-----------------------------------------------------------------------------------{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} +-- |+-- The core functional representation for literal values.+-- module Language.PureScript.CoreFn.Literals where -import qualified Data.Data as D- -- | -- Data type for literal values. Parameterised so it can be used for Exprs and -- Binders.@@ -47,4 +33,5 @@   -- |   -- An object literal   ---  | ObjectLiteral [(String, a)] deriving (Show, Read, D.Data, D.Typeable, Functor)+  | ObjectLiteral [(String, a)]+  deriving (Show, Read, Functor)
src/Language/PureScript/CoreFn/Meta.hs view
@@ -1,23 +1,8 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.CoreFn.Meta--- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>--- Stability   :  experimental--- Portability :------ | Metadata annotations for core functional representation+-- |+-- Metadata annotations for core functional representation ----------------------------------------------------------------------------------{-# LANGUAGE DeriveDataTypeable #-}- module Language.PureScript.CoreFn.Meta where -import qualified Data.Data as D- import Language.PureScript.Names  -- |@@ -39,7 +24,8 @@   -- |   -- The contained reference is for a foreign member   ---  | IsForeign deriving (Show, Read, D.Data, D.Typeable)+  | IsForeign+  deriving (Show, Read)  -- | -- Data constructor metadata@@ -52,4 +38,5 @@   -- |   -- The constructor is for a type with multiple construcors   ---  | SumType deriving (Show, Read, D.Data, D.Typeable)+  | SumType+  deriving (Show, Read)
src/Language/PureScript/CoreFn/Traversals.hs view
@@ -40,6 +40,7 @@    h' (LiteralBinder a b) = h (LiteralBinder a (handleLiteral h' b))   h' (NamedBinder a name b) = h (NamedBinder a name (h' b))+  h' (ConstructorBinder a q1 q2 bs) = h (ConstructorBinder a q1 q2 (map h' bs))   h' b = h b    handleCaseAlternative ca =
src/Language/PureScript/Docs/AsMarkdown.hs view
@@ -1,10 +1,19 @@ {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-} -module Language.PureScript.Docs.AsMarkdown (-  renderModulesAsMarkdown-) where+module Language.PureScript.Docs.AsMarkdown+  ( renderModulesAsMarkdown+  , Docs+  , runDocs+  , modulesAsMarkdown+  ) where -import Control.Monad.Writer hiding (First)+import Prelude ()+import Prelude.Compat++import Control.Monad (unless, zipWithM_)+import Control.Monad.Writer (Writer, tell, execWriter)+import Control.Monad.Error.Class (MonadError) import Data.Foldable (for_) import Data.List (partition) @@ -19,9 +28,14 @@ -- Take a list of modules and render them all in order, returning a single -- Markdown-formatted String. ---renderModulesAsMarkdown :: [P.Module] -> String-renderModulesAsMarkdown =-  runDocs . modulesAsMarkdown . map Convert.convertModule+renderModulesAsMarkdown ::+  (Functor m, Applicative m,+  MonadError P.MultipleErrors m) =>+  P.Env ->+  [P.Module] ->+  m String+renderModulesAsMarkdown env =+  fmap (runDocs . modulesAsMarkdown) . Convert.convertModules env  modulesAsMarkdown :: [Module] -> Docs modulesAsMarkdown = mapM_ moduleAsMarkdown@@ -31,17 +45,23 @@   headerLevel 2 $ "Module " ++ modName   spacer   for_ modComments tell'-  mapM_ declAsMarkdown modDeclarations+  mapM_ (declAsMarkdown modName) modDeclarations   spacer+  for_ modReExports $ \(mn, decls) -> do+    let modName' = P.runModuleName mn+    headerLevel 3 $ "Re-exported from " ++ modName' ++ ":"+    spacer+    mapM_ (declAsMarkdown modName') decls -declAsMarkdown :: Declaration -> Docs-declAsMarkdown decl@Declaration{..} = do+declAsMarkdown :: String -> Declaration -> Docs+declAsMarkdown mn decl@Declaration{..} = do+  let options = defaultRenderTypeOptions { currentModule = Just (P.moduleNameFromString mn) }   headerLevel 4 (ticks declTitle)   spacer    let (instances, children) = partition (isChildInstance . cdeclInfo) declChildren   fencedBlock $ do-    tell' (codeToString $ Render.renderDeclaration decl)+    tell' (codeToString $ Render.renderDeclarationWithOptions options decl)     zipWithM_ (\f c -> tell' (childToString f c)) (First : repeat NotFirst) children   spacer
src/Language/PureScript/Docs/Convert.hs view
@@ -2,225 +2,86 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE FlexibleContexts #-}  -- | Functions for converting PureScript ASTs into values of the data types -- from Language.PureScript.Docs.  module Language.PureScript.Docs.Convert-  ( convertModule+  ( convertModules+  , convertModulesInPackage   , collectBookmarks   ) where -import Control.Monad+import Prelude ()+import Prelude.Compat++import Control.Monad.Error.Class (MonadError)+import Control.Arrow ((&&&)) import Control.Category ((>>>))-import Data.Either-import Data.Maybe (mapMaybe, isNothing)-import Data.List (nub, isPrefixOf, isSuffixOf)+import qualified Data.Map as Map  import qualified Language.PureScript as P  import Language.PureScript.Docs.Types+import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks)+import Language.PureScript.Docs.Convert.ReExports (updateReExports)  -- |--- Convert a single Module.+-- Like convertModules, except that it takes a list of modules, together with+-- their dependency status, and discards dependency modules in the resulting+-- documentation. ---convertModule :: P.Module -> Module-convertModule m@(P.Module _ coms moduleName  _ _) =-  Module (P.runModuleName moduleName) comments (declarations m)+convertModulesInPackage ::+  (Functor m, MonadError P.MultipleErrors m) =>+  P.Env ->+  [InPackage P.Module] ->+  m [Module]+convertModulesInPackage env modules =+  go modules   where-  comments = convertComments coms-  declarations =-    P.exportedDeclarations-    >>> mapMaybe (\d -> getDeclarationTitle d >>= convertDeclaration d)-    >>> augmentDeclarations-    >>> map addDefaultFixity+  localNames =+    map (P.runModuleName . P.getModuleName) (takeLocals modules)+  go =+    map ignorePackage+     >>> convertModules env+     >>> fmap (filter ((`elem` localNames) . modName)) --- | The data type for an intermediate stage which we go through during--- converting.------ In the first pass, we take all top level declarations in the module, and--- collect other information which will later be used to augment the top level--- declarations. These two situation correspond to the Right and Left--- constructors, respectively.+-- |+-- Convert a group of modules to the intermediate format, designed for+-- producing documentation from. It is also necessary to pass an Env containing+-- imports/exports information about the list of modules, which is needed for+-- documenting re-exports. ----- In the second pass, we go over all of the Left values and augment the--- relevant declarations, leaving only the augmented Right values.+-- Preconditions: ----- Note that in the Left case, we provide a [String] as well as augment--- information. The [String] value should be a list of titles of declarations--- that the augmentation should apply to. For example, for a type instance--- declaration, that would be any types or type classes mentioned in the--- instance. For a fixity declaration, it would be just the relevant operator's--- name.-type IntermediateDeclaration-  = Either ([String], DeclarationAugment) Declaration---- | Some data which will be used to augment a Declaration in the--- output.+--     * If any module in the list re-exports documentation from other+--     modules, those modules must also be included in the list.+--     * The modules passed must have had names desugared and re-exports+--     elaborated first. ----- The AugmentChild constructor allows us to move all children under their--- respective parents. It is only necessary for type instance declarations,--- since they appear at the top level in the AST, and since they might need to--- appear as children in two places (for example, if a data type defined in a--- module is an instance of a type class also defined in that module).+-- If either of these are not satisfied, an internal error will be thrown. To+-- avoid this, it is recommended to use+-- Language.PureScript.Docs.ParseAndDesugar to construct the inputs to this+-- function. ----- The AugmentFixity constructor allows us to augment operator definitions--- with their associativity and precedence.-data DeclarationAugment-  = AugmentChild ChildDeclaration-  | AugmentFixity P.Fixity---- | Augment top-level declarations; the second pass. See the comments under--- the type synonym IntermediateDeclaration for more information.-augmentDeclarations :: [IntermediateDeclaration] -> [Declaration]-augmentDeclarations (partitionEithers -> (augments, toplevels)) =-  foldl go toplevels augments-  where-  go ds (parentTitles, a) =-    map (\d ->-      if declTitle d `elem` parentTitles-        then augmentWith a d-        else d) ds--  augmentWith a d =-    case a of-      AugmentChild child ->-        d { declChildren = declChildren d ++ [child] }-      AugmentFixity fixity ->-        d { declFixity = Just fixity }+convertModules ::+  (Functor m, MonadError P.MultipleErrors m) =>+  P.Env ->+  [P.Module] ->+  m [Module]+convertModules env =+  P.sortModules >>> fmap (convertSorted env . fst) --- | Add the default operator fixity for operators which do not have associated--- fixity declarations.+-- |+-- Convert a sorted list of modules. ----- TODO: This may no longer be necessary after issue 806 is resolved, hopefully--- in 0.8.-addDefaultFixity :: Declaration -> Declaration-addDefaultFixity decl@Declaration{..}-  | isOp declTitle && isNothing declFixity =-        decl { declFixity = Just defaultFixity }-  | otherwise =-        decl-  where-  isOp :: String -> Bool-  isOp str = "(" `isPrefixOf` str && ")" `isSuffixOf` str-  defaultFixity = P.Fixity P.Infixl (-1)--getDeclarationTitle :: P.Declaration -> Maybe String-getDeclarationTitle (P.TypeDeclaration name _)               = Just (P.showIdent name)-getDeclarationTitle (P.ExternDeclaration name _)             = Just (P.showIdent name)-getDeclarationTitle (P.DataDeclaration _ name _ _)           = Just (P.runProperName name)-getDeclarationTitle (P.ExternDataDeclaration name _)         = Just (P.runProperName name)-getDeclarationTitle (P.TypeSynonymDeclaration name _ _)      = Just (P.runProperName name)-getDeclarationTitle (P.TypeClassDeclaration name _ _ _)      = Just (P.runProperName name)-getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)-getDeclarationTitle (P.FixityDeclaration _ name)             = Just ("(" ++ name ++ ")")-getDeclarationTitle (P.PositionedDeclaration _ _ d)          = getDeclarationTitle d-getDeclarationTitle _                                        = Nothing---- | Create a basic Declaration value.-mkDeclaration :: String -> DeclarationInfo -> Declaration-mkDeclaration title info =-  Declaration { declTitle      = title-              , declComments   = Nothing-              , declSourceSpan = Nothing-              , declChildren   = []-              , declFixity     = Nothing-              , declInfo       = info-              }--basicDeclaration :: String -> DeclarationInfo -> Maybe IntermediateDeclaration-basicDeclaration title info = Just $ Right $ mkDeclaration title info--convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration-convertDeclaration (P.TypeDeclaration _ ty) title =-  basicDeclaration title (ValueDeclaration ty)-convertDeclaration (P.ExternDeclaration _ ty) title =-  basicDeclaration title (ValueDeclaration ty)-convertDeclaration (P.DataDeclaration dtype _ args ctors) title =-  Just (Right (mkDeclaration title info) { declChildren = children })-  where-  info = DataDeclaration dtype args-  children = map convertCtor ctors-  convertCtor (ctor', tys) =-    ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys)-convertDeclaration (P.ExternDataDeclaration _ kind') title =-  basicDeclaration title (ExternDataDeclaration kind')-convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =-  basicDeclaration title (TypeSynonymDeclaration args ty)-convertDeclaration (P.TypeClassDeclaration _ args implies ds) title =-  Just (Right (mkDeclaration title info) { declChildren = children })-  where-  info = TypeClassDeclaration args implies-  children = map convertClassMember ds-  convertClassMember (P.PositionedDeclaration _ _ d) =-    convertClassMember d-  convertClassMember (P.TypeDeclaration ident' ty) =-    ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty)-  convertClassMember _ =-    P.internalError "convertDeclaration: Invalid argument to convertClassMember."-convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title =-  Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))-  where-  classNameString = unQual className-  typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)-  unQual x = let (P.Qualified _ y) = x in P.runProperName y--  extractProperNames (P.TypeConstructor n) = [unQual n]-  extractProperNames _ = []--  childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)-  classApp = foldl P.TypeApp (P.TypeConstructor className) tys-convertDeclaration (P.FixityDeclaration fixity _) title =-  Just (Left ([title], AugmentFixity fixity))-convertDeclaration (P.PositionedDeclaration srcSpan com d') title =-  fmap (addComments . addSourceSpan) (convertDeclaration d' title)-  where-  addComments (Right d) =-    Right (d { declComments = convertComments com })-  addComments (Left augment) =-    Left (withAugmentChild (\d -> d { cdeclComments = convertComments com })-                           augment)--  addSourceSpan (Right d) =-    Right (d { declSourceSpan = Just srcSpan })-  addSourceSpan (Left augment) =-    Left (withAugmentChild (\d -> d { cdeclSourceSpan = Just srcSpan })-                           augment)--  withAugmentChild f (t, a) =-    case a of-      AugmentChild d -> (t, AugmentChild (f d))-      _              -> (t, a)-convertDeclaration _ _ = Nothing--convertComments :: [P.Comment] -> Maybe String-convertComments cs = do-  let raw = concatMap toLines cs-  guard (all hasPipe raw && not (null raw))-  return (go raw)-  where-  go = unlines . map stripPipes--  toLines (P.LineComment s) = [s]-  toLines (P.BlockComment s) = lines s--  hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False }--  stripPipes = dropPipe . dropWhile (== ' ')--  dropPipe ('|':' ':s) = s-  dropPipe ('|':s) = s-  dropPipe s = s---- | Go through a PureScript module and extract a list of Bookmarks; references--- to data types or values, to be used as a kind of index. These are used for--- generating links in the HTML documentation, for example.-collectBookmarks :: InPackage P.Module -> [Bookmark]-collectBookmarks (Local m) = map Local (collectBookmarks' m)-collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m)--collectBookmarks' :: P.Module -> [(P.ModuleName, String)]-collectBookmarks' m =-  map (P.getModuleName m, )-      (mapMaybe getDeclarationTitle-                (P.exportedDeclarations m))+convertSorted :: P.Env -> [P.Module] -> [Module]+convertSorted env modules =+  let+    traversalOrder =+      map P.getModuleName modules+    moduleMap =+      Map.fromList $ map (P.getModuleName &&& convertSingleModule) modules+  in+    Map.elems (updateReExports env traversalOrder moduleMap)
+ src/Language/PureScript/Docs/Convert/ReExports.hs view
@@ -0,0 +1,486 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-}++module Language.PureScript.Docs.Convert.ReExports+  ( updateReExports+  ) where++import Prelude ()+import Prelude.Compat++import Control.Monad+import Control.Monad.Trans.State.Strict (execState)+import Control.Monad.State.Class (MonadState, gets, modify)+import Control.Monad.Trans.Reader (runReaderT)+import Control.Monad.Reader.Class (MonadReader, ask)+import Control.Arrow ((&&&), first, second)+import Data.Either+import Data.Maybe (mapMaybe)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Monoid ((<>))++import qualified Language.PureScript as P++import Language.PureScript.Docs.Types++-- |+-- Given:+--+--      * The Imports/Exports Env+--      * An order to traverse the modules (which must be topological)+--      * A map of modules, indexed by their names, which are assumed to not+--      have their re-exports listed yet+--+-- This function adds all the missing re-exports.+--+updateReExports ::+  P.Env ->+  [P.ModuleName] ->+  Map P.ModuleName Module ->+  Map P.ModuleName Module+updateReExports env order modules =+  execState action modules+  where+  action =+    void (traverse go order)++  go mn = do+    mdl <- lookup' mn+    reExports <- getReExports env mn+    let mdl' = mdl { modReExports = reExports }+    modify (Map.insert mn mdl')++  lookup' mn = do+    v <- gets (Map.lookup mn)+    case v of+      Just v' ->+        pure v'+      Nothing ->+        internalError ("Module missing: " ++ P.runModuleName mn)++-- |+-- Collect all of the re-exported declarations for a single module.+--+-- We require that modules have already been sorted (P.sortModules) in order to+-- ensure that by the time we convert a particular module, all its dependencies+-- have already been converted.+--+getReExports ::+  (Functor m, Applicative m,+  MonadState (Map P.ModuleName Module) m) =>+  P.Env ->+  P.ModuleName ->+  m [(P.ModuleName, [Declaration])]+getReExports env mn =+  case Map.lookup mn env of+    Nothing ->+      internalError ("Module missing: " ++ P.runModuleName mn)+    Just (_, imports, exports) -> do+      allExports <- runReaderT (collectDeclarations imports exports) mn+      pure (filter notLocal allExports)++  where+  notLocal = (/= mn) . fst++-- |+-- Assemble a list of declarations re-exported from a particular module, based+-- on the Imports and Exports value for that module, and by extracting the+-- declarations from the current state.+--+-- This function works by searching through the lists of exported declarations+-- in the Exports, and looking them up in the associated Imports value to find+-- the module they were imported from.+--+-- Additionally:+--+--      * Attempts to move re-exported type class members under their parent+--      type classes, if possible, or otherwise, "promote" them from+--      ChildDeclarations to proper Declarations.+--      * Filters data declarations to ensure that only re-exported data+--      constructors are listed.+--      * Filters type class declarations to ensure that only re-exported type+--      class members are listed.+--+collectDeclarations ::+  (Functor m, Applicative m,+  MonadState (Map P.ModuleName Module) m,+  MonadReader P.ModuleName m) =>+  P.Imports ->+  P.Exports ->+  m [(P.ModuleName, [Declaration])]+collectDeclarations imports exports = do+  valsAndMembers <- collect lookupValueDeclaration     impVals  expVals+  typeClasses    <- collect lookupTypeClassDeclaration impTCs   expTCs+  types          <- collect lookupTypeDeclaration      impTypes expTypes++  (vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses++  let filteredTypes = filterDataConstructors expCtors types+  let filteredClasses = filterTypeClassMembers (map fst expVals) classes++  pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals]))++  where+  collect lookup' imps exps = do+    imps' <- traverse (findImport imps) exps+    Map.fromListWith (<>) <$> traverse (uncurry lookup') imps'++  expVals = P.exportedValues exports+  impVals = concat (Map.elems (P.importedValues imports))++  expTypes = map (first fst) (P.exportedTypes exports)+  impTypes = concat (Map.elems (P.importedTypes imports))++  expCtors = concatMap (snd . fst) (P.exportedTypes exports)++  expTCs = P.exportedTypeClasses exports+  impTCs = concat (Map.elems (P.importedTypeClasses imports))++-- |+-- Given a list of imported declarations (of a particular kind, ie. type, data,+-- class, value, etc), and the name of an exported declaration of the same+-- kind, together with the module it was originally defined in, return a tuple+-- of:+--+--      * the module that exported declaration was imported from (note that+--      this can be different from the module it was originally defined in, if+--      it is a re-export),+--      * that same declaration's name.+--+-- This function uses a type variable for names because we want to be able to+-- instantiate @name@ as both 'P.Ident' and 'P.ProperName'.+--+findImport ::+  (Show name, Eq name, Applicative m, MonadReader P.ModuleName m) =>+  [(P.Qualified name, P.ModuleName)] ->+  (name, P.ModuleName) ->+  m (P.ModuleName, name)+findImport imps (name, orig) =+  let+    matches (qual, mn) = P.disqualify qual == name && mn == orig+    matching = filter matches imps+    getQualified (P.Qualified mname _) = mname+  in+    case mapMaybe (getQualified . fst) matching of+      -- A value can occur more than once if it is imported twice (eg, if it is+      -- exported by A, re-exported from A by B, and C imports it from both A+      -- and B). In this case, we just take its first appearance.+      (importedFrom:_) ->+        pure (importedFrom, name)+      [] ->+        internalErrorInModule ("findImport: not found: " ++ show (name, orig))++lookupValueDeclaration ::+  (Applicative m,+  MonadState (Map P.ModuleName Module) m,+  MonadReader P.ModuleName m) =>+  P.ModuleName ->+  P.Ident ->+  m (P.ModuleName, [Either (String, P.Constraint, ChildDeclaration) Declaration])+lookupValueDeclaration importedFrom ident = do+  decls <- lookupModuleDeclarations "lookupValueDeclaration" importedFrom+  let+    rs =+      filter (\d -> declTitle d == P.showIdent ident+                    && (isValue d || isAlias d)) decls+    errOther other =+      internalErrorInModule+        ("lookupValueDeclaration: unexpected result:\n" +++          "other: " ++ show other ++ "\n" +++          "ident: " ++ show ident ++ "\n" +++          "decls: " ++ show decls)++  case rs of+    [r] ->+      pure (importedFrom, [Right r])+    [] ->+      -- It's a type class member.+      -- Note that we need to filter based on the child declaration info using+      -- `isTypeClassMember` anyway, because child declarations of type classes+      -- are not necessarily members; they could also be instances.+      let+        allTypeClassChildDecls =+          decls+           |> mapMaybe (\d -> (d,) <$> typeClassConstraintFor d)+           |> concatMap (\(d, constr) ->+                map (declTitle d, constr,)+                    (declChildren d))++        matchesIdent cdecl =+          cdeclTitle cdecl == P.showIdent ident++        matchesAndIsTypeClassMember =+          uncurry (&&) . (matchesIdent &&& isTypeClassMember)++      in+        case filter (matchesAndIsTypeClassMember . thd) allTypeClassChildDecls of+          [r'] ->+            pure (importedFrom, [Left r'])+          other ->+            errOther other+    other -> do+      errOther other++  where+  thd :: (a, b, c) -> c+  thd (_, _, x) = x++-- |+-- Extract a particular type declaration. For data declarations, constructors+-- are only included in the output if they are listed in the arguments.+--+lookupTypeDeclaration ::+  (Applicative m,+  MonadState (Map P.ModuleName Module) m,+  MonadReader P.ModuleName m) =>+  P.ModuleName ->+  P.ProperName 'P.TypeName ->+  m (P.ModuleName, [Declaration])+lookupTypeDeclaration importedFrom ty = do+  decls <- lookupModuleDeclarations "lookupTypeDeclaration" importedFrom+  let+    ds = filter (\d -> declTitle d == P.runProperName ty && isType d) decls+  case ds of+    [d] ->+      pure (importedFrom, [d])+    other ->+      internalErrorInModule+        ("lookupTypeDeclaration: unexpected result: " ++ show other)++lookupTypeClassDeclaration ::+  (Applicative m,+  MonadState (Map P.ModuleName Module) m,+  MonadReader P.ModuleName m) =>+  P.ModuleName ->+  P.ProperName 'P.ClassName ->+  m (P.ModuleName, [Declaration])+lookupTypeClassDeclaration importedFrom tyClass = do+  decls <- lookupModuleDeclarations "lookupTypeClassDeclaration" importedFrom+  let+    ds = filter (\d -> declTitle d == P.runProperName tyClass+                       && isTypeClass d)+                decls+  case ds of+    [d] ->+      pure (importedFrom, [d])+    other ->+      internalErrorInModule+        ("lookupTypeClassDeclaration: unexpected result: "+         ++ (unlines . map show) other)++-- |+-- Get the full list of declarations for a particular module out of the+-- state, or raise an internal error if it is not there.+--+lookupModuleDeclarations ::+  (Applicative m,+  MonadState (Map P.ModuleName Module) m,+  MonadReader P.ModuleName m) =>+  String ->+  P.ModuleName ->+  m [Declaration]+lookupModuleDeclarations definedIn moduleName = do+  mmdl <- gets (Map.lookup moduleName)+  case mmdl of+    Nothing ->+      internalErrorInModule+        (definedIn ++ ": module missing: "+         ++ P.runModuleName moduleName)+    Just mdl ->+      pure (allDeclarations mdl)++handleTypeClassMembers ::+  (Functor m, Applicative m,+  MonadReader P.ModuleName m) =>+  Map P.ModuleName [Either (String, P.Constraint, ChildDeclaration) Declaration] ->+  Map P.ModuleName [Declaration] ->+  m (Map P.ModuleName [Declaration], Map P.ModuleName [Declaration])+handleTypeClassMembers valsAndMembers typeClasses =+  let+    moduleEnvs =+      Map.unionWith (<>)+        (fmap valsAndMembersToEnv valsAndMembers)+        (fmap typeClassesToEnv typeClasses)+  in+    moduleEnvs+      |> traverse handleEnv+      |> fmap splitMap++valsAndMembersToEnv ::+  [Either (String, P.Constraint, ChildDeclaration) Declaration] -> TypeClassEnv+valsAndMembersToEnv xs =+  let (envUnhandledMembers, envValues) = partitionEithers xs+      envTypeClasses = []+  in TypeClassEnv{..}++typeClassesToEnv :: [Declaration] -> TypeClassEnv+typeClassesToEnv classes =+  TypeClassEnv+    { envUnhandledMembers = []+    , envValues = []+    , envTypeClasses = classes+    }++-- |+-- An intermediate data type, used for either moving type class members under+-- their parent type classes, or promoting them to normal Declaration values+-- if their parent type class has not been re-exported.+--+data TypeClassEnv = TypeClassEnv+  { -- |+    -- Type class members which have not yet been dealt with. The String is the+    -- name of the type class they belong to, and the constraint is used to+    -- make sure that they have the correct type if they get promoted.+    --+    envUnhandledMembers :: [(String, P.Constraint, ChildDeclaration)]+    -- |+    -- A list of normal value declarations. Type class members will be added to+    -- this list if their parent type class is not available.+    --+  , envValues :: [Declaration]+    -- |+    -- A list of type class declarations. Type class members will be added to+    -- their parents in this list, if they exist.+    --+  , envTypeClasses :: [Declaration]+  }+  deriving (Show)++instance Monoid TypeClassEnv where+  mempty =+    TypeClassEnv mempty mempty mempty+  mappend (TypeClassEnv a1 b1 c1)+          (TypeClassEnv a2 b2 c2) =+    TypeClassEnv (a1 <> a2) (b1 <> b2) (c1 <> c2)++-- |+-- Take a TypeClassEnv and handle all of the type class members in it, either+-- adding them to their parent classes, or promoting them to normal Declaration+-- values.+--+-- Returns a tuple of (values, type classes).+--+handleEnv ::+  (Functor m, Applicative m,+  MonadReader P.ModuleName m) =>+  TypeClassEnv ->+  m ([Declaration], [Declaration])+handleEnv TypeClassEnv{..} =+  envUnhandledMembers+    |> foldM go (envValues, mkMap envTypeClasses)+    |> fmap (second Map.elems)++  where+  mkMap =+    Map.fromList . map (declTitle &&& id)++  go (values, tcs) (title, constraint, childDecl) =+    case Map.lookup title tcs of+      Just _ ->+        -- Leave the state unchanged; if the type class is there, the child+        -- will be too.+        pure (values, tcs)+      Nothing -> do+        c <- promoteChild constraint childDecl+        pure (c : values, tcs)++  promoteChild constraint ChildDeclaration{..} =+    case cdeclInfo of+      ChildTypeClassMember typ ->+        pure $ Declaration+          { declTitle      = cdeclTitle+          , declComments   = cdeclComments+          , declSourceSpan = cdeclSourceSpan+          , declChildren   = []+          , declFixity     = Nothing+          , declInfo       = ValueDeclaration (addConstraint constraint typ)+          }+      _ ->+        internalErrorInModule+          ("handleEnv: Bad child declaration passed to promoteChild: "+          ++ cdeclTitle)++  addConstraint constraint =+    P.quantify . P.moveQuantifiersToFront . P.ConstrainedType [constraint]++splitMap :: (Ord k) => Map k (v1, v2) -> (Map k v1, Map k v2)+splitMap = foldl go (Map.empty, Map.empty) . Map.toList+  where+  go (m1, m2) (k, (v1, v2)) =+    (Map.insert k v1 m1, Map.insert k v2 m2)++-- |+-- Given a list of exported constructor names, remove any data constructor+-- names in the provided Map of declarations which are not in the list.+--+filterDataConstructors ::+  [P.ProperName 'P.ConstructorName] ->+  Map P.ModuleName [Declaration] ->+  Map P.ModuleName [Declaration]+filterDataConstructors =+  filterExportedChildren isDataConstructor P.runProperName++-- |+-- Given a list of exported type class member names, remove any data+-- type class member names in the provided Map of declarations which are not in+-- the list.+--+filterTypeClassMembers ::+  [P.Ident] ->+  Map P.ModuleName [Declaration] ->+  Map P.ModuleName [Declaration]+filterTypeClassMembers =+  filterExportedChildren isTypeClassMember P.showIdent++filterExportedChildren ::+  (Functor f) =>+  (ChildDeclaration -> Bool) ->+  (name -> String) ->+  [name] ->+  f [Declaration] ->+  f [Declaration]+filterExportedChildren isTargetedKind runName expNames =+  fmap filterDecls+  where+  filterDecls =+    map (filterChildren (\c -> not (isTargetedKind c) ||+                               cdeclTitle c `elem` expNames'))++  expNames' = map runName expNames++allDeclarations :: Module -> [Declaration]+allDeclarations Module{..} =+  modDeclarations ++ concatMap snd modReExports++(|>) :: a -> (a -> b) -> b+x |> f = f x++internalError :: String -> a+internalError = P.internalError . ("Docs.Convert.ReExports: " ++)++internalErrorInModule ::+  (MonadReader P.ModuleName m) =>+  String ->+  m a+internalErrorInModule msg = do+  mn <- ask+  internalError+    ("while collecting re-exports for module: " ++ P.runModuleName mn +++     ", " ++ msg)++-- |+-- If the provided Declaration is a TypeClassDeclaration, construct an+-- appropriate Constraint for use with the types of its members.+--+typeClassConstraintFor :: Declaration -> Maybe P.Constraint+typeClassConstraintFor Declaration{..} =+  case declInfo of+    TypeClassDeclaration tyArgs _ ->+      Just (P.Qualified Nothing (P.ProperName declTitle), mkConstraint tyArgs)+    _ ->+      Nothing+  where+  mkConstraint = map (P.TypeVar . fst)
+ src/Language/PureScript/Docs/Convert/Single.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE FlexibleContexts #-}++module Language.PureScript.Docs.Convert.Single+  ( convertSingleModule+  , collectBookmarks+  ) where++import Prelude ()+import Prelude.Compat+import Data.Maybe (catMaybes)++import Control.Monad+import Control.Category ((>>>))+import Data.Maybe (mapMaybe, isNothing)+import Data.Either+import Data.List (nub, isPrefixOf, isSuffixOf)++import qualified Language.PureScript as P++import Language.PureScript.Docs.Types++-- |+-- Convert a single Module, but ignore re-exports; any re-exported types or+-- values will not appear in the result.+--+convertSingleModule :: P.Module -> Module+convertSingleModule m@(P.Module _ coms moduleName  _ _) =+  Module (P.runModuleName moduleName) comments (declarations m) []+  where+  comments = convertComments coms+  declarations =+    P.exportedDeclarations+    >>> mapMaybe (\d -> getDeclarationTitle d >>= convertDeclaration d)+    >>> augmentDeclarations+    >>> map addDefaultFixity++-- | The data type for an intermediate stage which we go through during+-- converting.+--+-- In the first pass, we take all top level declarations in the module, and+-- collect other information which will later be used to augment the top level+-- declarations. These two situation correspond to the Right and Left+-- constructors, respectively.+--+-- In the second pass, we go over all of the Left values and augment the+-- relevant declarations, leaving only the augmented Right values.+--+-- Note that in the Left case, we provide a [String] as well as augment+-- information. The [String] value should be a list of titles of declarations+-- that the augmentation should apply to. For example, for a type instance+-- declaration, that would be any types or type classes mentioned in the+-- instance. For a fixity declaration, it would be just the relevant operator's+-- name.+type IntermediateDeclaration+  = Either ([String], DeclarationAugment) Declaration++-- | Some data which will be used to augment a Declaration in the+-- output.+--+-- The AugmentChild constructor allows us to move all children under their+-- respective parents. It is only necessary for type instance declarations,+-- since they appear at the top level in the AST, and since they might need to+-- appear as children in two places (for example, if a data type defined in a+-- module is an instance of a type class also defined in that module).+--+-- The AugmentFixity constructor allows us to augment operator definitions+-- with their associativity and precedence.+data DeclarationAugment+  = AugmentChild ChildDeclaration+  | AugmentFixity P.Fixity++-- | Augment top-level declarations; the second pass. See the comments under+-- the type synonym IntermediateDeclaration for more information.+augmentDeclarations :: [IntermediateDeclaration] -> [Declaration]+augmentDeclarations (partitionEithers -> (augments, toplevels)) =+  foldl go toplevels augments+  where+  go ds (parentTitles, a) =+    map (\d ->+      if declTitle d `elem` parentTitles+        then augmentWith a d+        else d) ds++  augmentWith a d =+    case a of+      AugmentChild child ->+        d { declChildren = declChildren d ++ [child] }+      AugmentFixity fixity ->+        d { declFixity = Just fixity }++-- | Add the default operator fixity for operators which do not have associated+-- fixity declarations.+--+-- TODO: This may no longer be necessary after issue 806 is resolved, hopefully+-- in 0.9.+addDefaultFixity :: Declaration -> Declaration+addDefaultFixity decl@Declaration{..}+  | isOp declTitle && isNothing declFixity =+        decl { declFixity = Just defaultFixity }+  | otherwise =+        decl+  where+  isOp :: String -> Bool+  isOp str = "(" `isPrefixOf` str && ")" `isSuffixOf` str+  defaultFixity = P.Fixity P.Infixl (-1)++getDeclarationTitle :: P.Declaration -> Maybe String+getDeclarationTitle (P.TypeDeclaration name _)               = Just (P.showIdent name)+getDeclarationTitle (P.ExternDeclaration name _)             = Just (P.showIdent name)+getDeclarationTitle (P.DataDeclaration _ name _ _)           = Just (P.runProperName name)+getDeclarationTitle (P.ExternDataDeclaration name _)         = Just (P.runProperName name)+getDeclarationTitle (P.TypeSynonymDeclaration name _ _)      = Just (P.runProperName name)+getDeclarationTitle (P.TypeClassDeclaration name _ _ _)      = Just (P.runProperName name)+getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)+getDeclarationTitle (P.FixityDeclaration _ name _)           = Just ("(" ++ name ++ ")")+getDeclarationTitle (P.PositionedDeclaration _ _ d)          = getDeclarationTitle d+getDeclarationTitle _                                        = Nothing++-- | Create a basic Declaration value.+mkDeclaration :: String -> DeclarationInfo -> Declaration+mkDeclaration title info =+  Declaration { declTitle      = title+              , declComments   = Nothing+              , declSourceSpan = Nothing+              , declChildren   = []+              , declFixity     = Nothing+              , declInfo       = info+              }++basicDeclaration :: String -> DeclarationInfo -> Maybe IntermediateDeclaration+basicDeclaration title info = Just $ Right $ mkDeclaration title info++convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration+convertDeclaration (P.TypeDeclaration _ ty) title =+  basicDeclaration title (ValueDeclaration ty)+convertDeclaration (P.ExternDeclaration _ ty) title =+  basicDeclaration title (ValueDeclaration ty)+convertDeclaration (P.DataDeclaration dtype _ args ctors) title =+  Just (Right (mkDeclaration title info) { declChildren = children })+  where+  info = DataDeclaration dtype args+  children = map convertCtor ctors+  convertCtor (ctor', tys) =+    ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys)+convertDeclaration (P.ExternDataDeclaration _ kind') title =+  basicDeclaration title (ExternDataDeclaration kind')+convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =+  basicDeclaration title (TypeSynonymDeclaration args ty)+convertDeclaration (P.TypeClassDeclaration _ args implies ds) title =+  Just (Right (mkDeclaration title info) { declChildren = children })+  where+  info = TypeClassDeclaration args implies+  children = map convertClassMember ds+  convertClassMember (P.PositionedDeclaration _ _ d) =+    convertClassMember d+  convertClassMember (P.TypeDeclaration ident' ty) =+    ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty)+  convertClassMember _ =+    P.internalError "convertDeclaration: Invalid argument to convertClassMember."+convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title =+  Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))+  where+  classNameString = unQual className+  typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)+  unQual x = let (P.Qualified _ y) = x in P.runProperName y++  extractProperNames (P.TypeConstructor n) = [unQual n]+  extractProperNames _ = []++  childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)+  classApp = foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys+convertDeclaration (P.FixityDeclaration fixity _ Nothing) title =+  Just (Left ([title], AugmentFixity fixity))+convertDeclaration (P.FixityDeclaration fixity _ (Just alias)) title =+  Just $ Right $ (mkDeclaration title (AliasDeclaration alias fixity)) { declFixity = Just fixity }+convertDeclaration (P.PositionedDeclaration srcSpan com d') title =+  fmap (addComments . addSourceSpan) (convertDeclaration d' title)+  where+  addComments (Right d) =+    Right (d { declComments = convertComments com })+  addComments (Left augment) =+    Left (withAugmentChild (\d -> d { cdeclComments = convertComments com })+                           augment)++  addSourceSpan (Right d) =+    Right (d { declSourceSpan = Just srcSpan })+  addSourceSpan (Left augment) =+    Left (withAugmentChild (\d -> d { cdeclSourceSpan = Just srcSpan })+                           augment)++  withAugmentChild f (t, a) =+    case a of+      AugmentChild d -> (t, AugmentChild (f d))+      _              -> (t, a)+convertDeclaration _ _ = Nothing++convertComments :: [P.Comment] -> Maybe String+convertComments cs = do+  let raw = concatMap toLines cs+  let docs = catMaybes (map stripPipe raw)+  guard (not (null docs))+  pure (unlines docs)++  where+  toLines (P.LineComment s) = [s]+  toLines (P.BlockComment s) = lines s++  stripPipe s' =+    case dropWhile (== ' ') s' of+      ('|':' ':s) ->+        Just s+      ('|':s) ->+        Just s+      _ ->+        Nothing++-- | Go through a PureScript module and extract a list of Bookmarks; references+-- to data types or values, to be used as a kind of index. These are used for+-- generating links in the HTML documentation, for example.+collectBookmarks :: InPackage P.Module -> [Bookmark]+collectBookmarks (Local m) = map Local (collectBookmarks' m)+collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m)++collectBookmarks' :: P.Module -> [(P.ModuleName, String)]+collectBookmarks' m =+  map (P.getModuleName m, )+      (mapMaybe getDeclarationTitle+                (P.exportedDeclarations m))
src/Language/PureScript/Docs/ParseAndDesugar.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleContexts #-}  module Language.PureScript.Docs.ParseAndDesugar   ( parseAndDesugar-  , ParseDesugarError(..)   ) where  import Prelude ()@@ -12,7 +12,6 @@ import Control.Arrow (first) import Control.Monad -import Control.Monad.Trans.Except import Control.Monad.Writer.Strict (runWriterT) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..))@@ -24,73 +23,69 @@ import Language.PureScript.Docs.Types import Language.PureScript.Docs.Convert (collectBookmarks) -data ParseDesugarError-  = ParseError P.MultipleErrors-  | SortModulesError P.MultipleErrors-  | DesugarError P.MultipleErrors-  deriving (Show)- -- | -- Given: -- --    * A list of local source files --    * A list of source files from external dependencies, together with their --      package names---    * A callback, taking a list of bookmarks, and a list of desugared modules -- -- This function does the following: -- --    * Parse all of the input and dependency source files---    * Partially desugar all of the resulting modules+--    * Associate each dependency module with its package name, thereby+--      distinguishing these from local modules+--    * Partially desugar all of the resulting modules (just enough for+--      producing documentation from them) --    * Collect a list of bookmarks from the whole set of source files---    * Collect a list of desugared modules from just the input source files (not---      dependencies)---    * Call the callback with the bookmarks and desugared module list.+--    * Return the desugared modules, the bookmarks, and the imports/exports+--      Env (which is needed for producing documentation). parseAndDesugar ::+  (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadIO m) =>   [FilePath]   -> [(PackageName, FilePath)]-  -> ([Bookmark] -> [P.Module] -> IO a)-  -> IO (Either ParseDesugarError a)-parseAndDesugar inputFiles depsFiles callback = do+  -> m ([InPackage P.Module], [Bookmark], P.Env)+parseAndDesugar inputFiles depsFiles = do   inputFiles' <- traverse (parseAs Local) inputFiles   depsFiles'  <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles -  runExceptT $ do-    ms         <- parseFiles (inputFiles' ++ depsFiles')-    ms'        <- sortModules (map snd ms)-    (bs, ms'') <- desugarWithBookmarks ms ms'-    liftIO $ callback bs ms''+  ms  <- parseFiles (inputFiles' ++ depsFiles')+  ms' <- sortModules (map snd ms)+  desugarWithBookmarks ms ms'  parseFiles ::+  (MonadError P.MultipleErrors m, MonadIO m) =>   [(FileInfo, FilePath)]-  -> ExceptT ParseDesugarError IO [(FileInfo, P.Module)]+  -> m [(FileInfo, P.Module)] parseFiles =-  throwLeft ParseError . P.parseModulesFromFiles fileInfoToString+  throwLeft . P.parseModulesFromFiles fileInfoToString  sortModules ::+  (Functor m, MonadError P.MultipleErrors m, MonadIO m) =>   [P.Module]-  -> ExceptT ParseDesugarError IO [P.Module]+  -> m [P.Module] sortModules =-  fmap fst . throwLeft SortModulesError . sortModules' . map importPrim+  fmap fst . throwLeft . sortModules' . map importPrim   where   sortModules' :: [P.Module] -> Either P.MultipleErrors ([P.Module], P.ModuleGraph)   sortModules' = P.sortModules  desugarWithBookmarks ::+  (MonadError P.MultipleErrors m, MonadIO m) =>   [(FileInfo, P.Module)]   -> [P.Module]-  -> ExceptT ParseDesugarError IO ([Bookmark], [P.Module])+  -> m ([InPackage P.Module], [Bookmark], P.Env) desugarWithBookmarks msInfo msSorted =  do-  msDesugared <- throwLeft DesugarError (desugar msSorted)+  (env, msDesugared) <- throwLeft (desugar msSorted)    let msDeps = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) msInfo)       msPackages = map (addPackage msDeps) msDesugared       bookmarks = concatMap collectBookmarks msPackages -  return (bookmarks, takeLocals msPackages)+  return (msPackages, bookmarks, env) -throwLeft :: (MonadError e m) => (l -> e) -> Either l r -> m r-throwLeft f = either (throwError . f) return+throwLeft :: (MonadError l m) => Either l r -> m r+throwLeft = either throwError return  -- | Specifies whether a PureScript source file is considered as: --@@ -105,30 +100,27 @@ fileInfoToString (Local fn) = fn fileInfoToString (FromDep _ fn) = fn -addDefaultImport :: P.ModuleName -> P.Module -> P.Module-addDefaultImport toImport m@(P.Module ss coms mn decls exps)  =-  if isExistingImport `any` decls || mn == toImport then m-  else P.Module ss coms mn (P.ImportDeclaration toImport P.Implicit Nothing : decls) exps-  where-  isExistingImport (P.ImportDeclaration mn' _ _) | mn' == toImport = True-  isExistingImport (P.PositionedDeclaration _ _ d) = isExistingImport d-  isExistingImport _ = False- importPrim :: P.Module -> P.Module-importPrim = addDefaultImport (P.ModuleName [P.ProperName C.prim])+importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim]) -desugar :: [P.Module] -> Either P.MultipleErrors [P.Module]+desugar ::+  (Functor m, Applicative m, MonadError P.MultipleErrors m) =>+  [P.Module]+  -> m (P.Env, [P.Module]) desugar = P.evalSupplyT 0 . desugar'   where-  desugar' :: [P.Module] -> P.SupplyT (Either P.MultipleErrors) [P.Module]-  desugar' = traverse P.desugarDoModule >=> P.desugarCasesModule >=> ignoreWarnings . P.desugarImports []+  desugar' =+    traverse P.desugarDoModule+      >=> P.desugarCasesModule+      >=> ignoreWarnings . P.desugarImportsWithEnv []+   ignoreWarnings m = liftM fst (runWriterT m)  parseFile :: FilePath -> IO (FilePath, String) parseFile input' = (,) input' <$> readFile input' -parseAs :: (FilePath -> a) -> FilePath -> IO (a, String)-parseAs g = fmap (first g) . parseFile+parseAs :: (Functor m, MonadIO m) => (FilePath -> a) -> FilePath -> m (a, String)+parseAs g = fmap (first g) . liftIO . parseFile  getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName getDepsModuleNames = foldl go M.empty
src/Language/PureScript/Docs/Render.hs view
@@ -49,7 +49,7 @@       [ keywordClass ]       ++ maybeToList superclasses       ++ [renderType' (typeApp declTitle args)]-      ++ [keywordWhere | any (isTypeClassMember . cdeclInfo) declChildren]+      ++ [keywordWhere | any isTypeClassMember declChildren]        where       superclasses@@ -58,11 +58,19 @@             syntax "("             <> mintersperse (syntax "," <> sp) (map renderConstraint implies)             <> syntax ")" <> sp <> syntax "<="+    AliasDeclaration for (P.Fixity associativity precedence) ->+      [ keywordFixity associativity+      , syntax $ show precedence+      , ident $ P.showQualified P.runIdent $ dequalifyCurrentModule for+      , keyword "as"+      , ident . tail . init $ declTitle+      ] -      isTypeClassMember (ChildTypeClassMember _) = True-      isTypeClassMember _ = False   where   renderType' = renderTypeWithOptions opts+  dequalifyCurrentModule (P.Qualified mn a)+    | mn == currentModule opts = P.Qualified Nothing a+    | otherwise = P.Qualified mn a  renderChildDeclaration :: ChildDeclaration -> RenderedCode renderChildDeclaration = renderChildDeclarationWithOptions defaultRenderTypeOptions@@ -86,12 +94,12 @@   where   renderType' = renderTypeWithOptions opts -renderConstraint :: (P.Qualified P.ProperName, [P.Type]) -> RenderedCode+renderConstraint :: P.Constraint -> RenderedCode renderConstraint = renderConstraintWithOptions defaultRenderTypeOptions -renderConstraintWithOptions :: RenderTypeOptions -> (P.Qualified P.ProperName, [P.Type]) -> RenderedCode+renderConstraintWithOptions :: RenderTypeOptions -> P.Constraint -> RenderedCode renderConstraintWithOptions opts (pn, tys) =-  renderTypeWithOptions opts $ foldl P.TypeApp (P.TypeConstructor pn) tys+  renderTypeWithOptions opts $ foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName pn)) tys  renderConstraints :: [P.Constraint] -> Maybe RenderedCode renderConstraints = renderConstraintsWithOptions defaultRenderTypeOptions@@ -108,7 +116,7 @@     mintersperse (syntax "," <> sp)                  (map (renderConstraintWithOptions opts) constraints) -notQualified :: String -> P.Qualified P.ProperName+notQualified :: String -> P.Qualified (P.ProperName a) notQualified = P.Qualified Nothing . P.ProperName  typeApp :: String -> [(String, Maybe P.Kind)] -> P.Type
src/Language/PureScript/Docs/RenderedCode/Render.hs view
@@ -9,7 +9,7 @@     defaultRenderTypeOptions,     renderTypeWithOptions ) where-  + import Prelude () import Prelude.Compat @@ -52,9 +52,10 @@             ]     where     constraints = mintersperse (syntax "," <> sp) (map renderDep deps)+    renderDep :: Constraint -> RenderedCode     renderDep (pn, tys) =-        let instApp = foldl TypeApp (TypeConstructor pn) tys-        in  renderType instApp+      let instApp = foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys+      in  renderType instApp   match REmpty =     Just (syntax "()")   match row@RCons{} =@@ -172,10 +173,15 @@  data RenderTypeOptions = RenderTypeOptions   { prettyPrintObjects :: Bool+  , currentModule :: Maybe ModuleName   }  defaultRenderTypeOptions :: RenderTypeOptions-defaultRenderTypeOptions = RenderTypeOptions { prettyPrintObjects = True }+defaultRenderTypeOptions =+  RenderTypeOptions+    { prettyPrintObjects = True+    , currentModule = Nothing+    }  renderTypeWithOptions :: RenderTypeOptions -> Type -> RenderedCode renderTypeWithOptions opts =
src/Language/PureScript/Docs/RenderedCode/Types.hs view
@@ -28,6 +28,7 @@  , keywordClass  , keywordInstance  , keywordWhere+ , keywordFixity  ) where  import Prelude ()@@ -189,3 +190,8 @@  keywordWhere :: RenderedCode keywordWhere = keyword "where"++keywordFixity :: P.Associativity -> RenderedCode+keywordFixity P.Infixl = keyword "infixl"+keywordFixity P.Infixr = keyword "infixr"+keywordFixity P.Infix = keyword "infix"
src/Language/PureScript/Docs/Types.hs view
@@ -76,6 +76,8 @@   { modName         :: String   , modComments     :: Maybe String   , modDeclarations :: [Declaration]+  -- Re-exported values from other modules+  , modReExports    :: [(P.ModuleName, [Declaration])]   }   deriving (Show, Eq, Ord) @@ -84,7 +86,7 @@   , declComments   :: Maybe String   , declSourceSpan :: Maybe P.SourceSpan   , declChildren   :: [ChildDeclaration]-  , declFixity     :: Maybe P.Fixity+  , declFixity     :: Maybe P.Fixity -- TODO: remove in 0.9   , declInfo       :: DeclarationInfo   }   deriving (Show, Eq, Ord)@@ -126,6 +128,12 @@   -- members are represented as child declarations.   --   | TypeClassDeclaration [(String, Maybe P.Kind)] [P.Constraint]++  -- |+  -- An operator alias declaration, with the member the alias is for and the+  -- operator's fixity.+  --+  | AliasDeclaration (P.Qualified P.Ident) P.Fixity   deriving (Show, Eq, Ord)  declInfoToString :: DeclarationInfo -> String@@ -134,7 +142,39 @@ declInfoToString (ExternDataDeclaration _) = "externData" declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym" declInfoToString (TypeClassDeclaration _ _) = "typeClass"+declInfoToString (AliasDeclaration _ _) = "alias" +isTypeClass :: Declaration -> Bool+isTypeClass Declaration{..} =+  case declInfo of+    TypeClassDeclaration{} -> True+    _ -> False++isValue :: Declaration -> Bool+isValue Declaration{..} =+  case declInfo of+    ValueDeclaration{} -> True+    _ -> False++isType :: Declaration ->  Bool+isType Declaration{..} =+  case declInfo of+    TypeSynonymDeclaration{} -> True+    DataDeclaration{} -> True+    ExternDataDeclaration{} -> True+    _ -> False++isAlias :: Declaration -> Bool+isAlias Declaration{..} =+  case declInfo of+    AliasDeclaration{} -> True+    _ -> False++-- | Discard any children which do not satisfy the given predicate.+filterChildren :: (ChildDeclaration -> Bool) -> Declaration -> Declaration+filterChildren p decl =+  decl { declChildren = filter p (declChildren decl) }+ data ChildDeclaration = ChildDeclaration   { cdeclTitle      :: String   , cdeclComments   :: Maybe String@@ -167,6 +207,18 @@ childDeclInfoToString (ChildDataConstructor _) = "dataConstructor" childDeclInfoToString (ChildTypeClassMember _) = "typeClassMember" +isTypeClassMember :: ChildDeclaration -> Bool+isTypeClassMember ChildDeclaration{..} =+  case cdeclInfo of+    ChildTypeClassMember{} -> True+    _ -> False++isDataConstructor :: ChildDeclaration -> Bool+isDataConstructor ChildDeclaration{..} =+  case cdeclInfo of+    ChildDataConstructor{} -> True+    _ -> False+ newtype GithubUser   = GithubUser { runGithubUser :: String }   deriving (Show, Eq, Ord)@@ -297,6 +349,7 @@   Module <$> key "name" asString          <*> key "comments" (perhaps asString)          <*> key "declarations" (eachInArray asDeclaration)+         <*> key "reExports" (eachInArray asReExport)  asDeclaration :: Parse PackageError Declaration asDeclaration =@@ -307,9 +360,23 @@               <*> key "fixity" (perhaps asFixity)               <*> key "info" asDeclarationInfo +asReExport :: Parse PackageError (P.ModuleName, [Declaration])+asReExport =+  (,) <$> key "moduleName" fromAesonParser+      <*> key "declarations" (eachInArray asDeclaration)++asInPackage :: Parse BowerError a -> Parse BowerError (InPackage a)+asInPackage inner =+  build <$> key "package" (perhaps (withString parsePackageName))+        <*> key "item" inner+  where+  build Nothing = Local+  build (Just pn) = FromDep pn+ asFixity :: Parse PackageError P.Fixity-asFixity = P.Fixity <$> key "associativity" asAssociativity-                    <*> key "precedence" asIntegral+asFixity =+  P.Fixity <$> key "associativity" asAssociativity+           <*> key "precedence" asIntegral  parseAssociativity :: String -> Maybe P.Associativity parseAssociativity str = case str of@@ -338,6 +405,9 @@     "typeClass" ->       TypeClassDeclaration <$> key "arguments" asTypeArguments                            <*> key "superclasses" (eachInArray asConstraint)+    "alias" ->+      AliasDeclaration <$> key "for" asQualifiedIdent+                       <*> key "fixity" asFixity     other ->       throwCustomError (InvalidDeclarationType other) @@ -388,20 +458,19 @@ asConstraint = (,) <$> nth 0 asQualifiedProperName                    <*> nth 1 (eachInArray asType) -asQualifiedProperName :: Parse e (P.Qualified P.ProperName)+asQualifiedProperName :: Parse e (P.Qualified (P.ProperName a)) asQualifiedProperName = fromAesonParser +asQualifiedIdent :: Parse e (P.Qualified P.Ident)+asQualifiedIdent = fromAesonParser+ asBookmarks :: Parse BowerError [Bookmark] asBookmarks = eachInArray asBookmark  asBookmark :: Parse BowerError Bookmark asBookmark =-  build <$> key "package" (perhaps (withString parsePackageName))-        <*> key "item" ((,) <$> nth 0 (P.moduleNameFromString <$> asString)-                            <*> nth 1 asString)-  where-  build Nothing = Local-  build (Just pn) = FromDep pn+  asInPackage ((,) <$> nth 0 (P.moduleNameFromString <$> asString)+                   <*> nth 1 asString)  asResolvedDependencies :: Parse PackageError [(PackageName, Version)] asResolvedDependencies =@@ -446,7 +515,12 @@     A.object [ "name"         .= modName              , "comments"     .= modComments              , "declarations" .= modDeclarations+             , "reExports"    .= map toObj modReExports              ]+    where+    toObj (mn, decls) = A.object [ "moduleName" .= mn+                                 , "declarations" .= decls+                                 ]  instance A.ToJSON Declaration where   toJSON Declaration{..} =@@ -475,6 +549,7 @@       ExternDataDeclaration kind -> ["kind" .= kind]       TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty]       TypeClassDeclaration args super -> ["arguments" .= args, "superclasses" .= super]+      AliasDeclaration for fixity -> ["for" .= for, "fixity" .= fixity]  instance A.ToJSON ChildDeclarationInfo where   toJSON info = A.object $ "declType" .= childDeclInfoToString info : props
src/Language/PureScript/Environment.hs view
@@ -1,24 +1,8 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Environment--- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |-----------------------------------------------------------------------------------{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}  module Language.PureScript.Environment where -import Data.Data import Data.Maybe (fromMaybe) import Data.Aeson.TH import qualified Data.Map as M@@ -43,30 +27,30 @@   -- |   -- Type names currently in scope   ---  , types :: M.Map (Qualified ProperName) (Kind, TypeKind)+  , types :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)   -- |   -- Data constructors currently in scope, along with their associated type   -- constructor name, argument types and return type.-  , dataConstructors :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident])+  , dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, Type, [Ident])   -- |   -- Type synonyms currently in scope   ---  , typeSynonyms :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], Type)+  , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(String, Maybe Kind)], Type)   -- |   -- Available type class dictionaries   ---  , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope))+  , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))   -- |   -- Type classes   ---  , typeClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])+  , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])   } deriving (Show, Read)  -- | -- The initial environment with no values and only the default javascript types defined -- initEnvironment :: Environment-initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty M.empty+initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses  -- | -- The visibility of a name in scope@@ -98,7 +82,8 @@   -- |   -- A name for member introduced by foreign import   ---  | External deriving (Show, Read, Eq, Data, Typeable)+  | External+  deriving (Show, Read, Eq)  -- | -- The kinds of a type@@ -107,7 +92,7 @@   -- |   -- Data type   ---  = DataType [(String, Maybe Kind)] [(ProperName, [Type])]+  = DataType [(String, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]   -- |   -- Type synonym   --@@ -124,7 +109,7 @@   -- A scoped type variable   --   | ScopedTypeVar-   deriving (Show, Read, Eq, Data, Typeable)+  deriving (Show, Read, Eq)  -- | -- The type ('data' or 'newtype') of a data type declaration@@ -137,7 +122,8 @@   -- |   -- A newtype constructor   ---  | Newtype deriving (Show, Read, Eq, Ord, Data, Typeable)+  | Newtype+  deriving (Show, Read, Eq, Ord)  showDataDeclType :: DataDeclType -> String showDataDeclType Data = "data"@@ -156,7 +142,7 @@ -- | -- Construct a ProperName in the Prim module ---primName :: String -> Qualified ProperName+primName :: String -> Qualified (ProperName a) primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName  -- |@@ -236,29 +222,44 @@ function t1 = TypeApp (TypeApp tyFunction t1)  -- |--- The primitive types in the external javascript environment with their associated kinds.+-- 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. ---primTypes :: M.Map (Qualified ProperName) (Kind, TypeKind)-primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star), ExternData))-                       , (primName "Array"    , (FunKind Star Star, ExternData))-                       , (primName "Object"   , (FunKind (Row Star) Star, ExternData))-                       , (primName "String"   , (Star, ExternData))-                       , (primName "Char"     , (Star, ExternData))-                       , (primName "Number"   , (Star, ExternData))-                       , (primName "Int"      , (Star, ExternData))-                       , (primName "Boolean"  , (Star, ExternData)) ]+primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)+primTypes =+  M.fromList+    [ (primName "Function", (FunKind Star (FunKind Star Star), ExternData))+    , (primName "Array", (FunKind Star Star, ExternData))+    , (primName "Object", (FunKind (Row Star) Star, ExternData))+    , (primName "String", (Star, ExternData))+    , (primName "Char", (Star, ExternData))+    , (primName "Number", (Star, ExternData))+    , (primName "Int", (Star, ExternData))+    , (primName "Boolean", (Star, ExternData))+    , (primName "Partial", (Star, ExternData))+    ]  -- |+-- The primitive class map. This just contains to `Partial` class, used as a+-- kind of magic constraint for partial functions.+--+primClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])+primClasses =+  M.fromList+    [ (primName "Partial", ([], [], [])) ]++-- | -- Finds information about data constructors from the current environment. ---lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type, [Ident])+lookupConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> (DataDeclType, ProperName 'TypeName, Type, [Ident]) lookupConstructor env ctor =   fromMaybe (internalError "Data constructor not found") $ ctor `M.lookup` dataConstructors env  -- | -- Checks whether a data constructor is for a newtype. ---isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool+isNewtypeConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> Bool isNewtypeConstructor e ctor = case lookupConstructor e ctor of   (Newtype, _, _, _) -> True   (Data, _, _, _) -> False
src/Language/PureScript/Errors.hs view
@@ -1,17 +1,3 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Error--- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess--- License     :  MIT (http://opensource.org/licenses/MIT)------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |---------------------------------------------------------------------------------- {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -21,9 +7,10 @@ import Prelude () import Prelude.Compat +import Data.Ord (comparing)+import Data.Char (isSpace) import Data.Either (lefts, rights)-import Data.List (intercalate, transpose, nub, nubBy)-import Data.Function (on)+import Data.List (intercalate, transpose, nub, nubBy, sortBy) import Data.Foldable (fold)  import qualified Data.Map as M@@ -32,7 +19,7 @@ import Control.Monad.Writer import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Trans.State.Lazy-import Control.Arrow (first)+import Control.Arrow ((&&&))  import Language.PureScript.Crash import Language.PureScript.AST@@ -66,64 +53,63 @@   | RedefinedIdent Ident   | OverlappingNamesInLet   | UnknownModule ModuleName-  | UnknownType (Qualified ProperName)-  | UnknownTypeClass (Qualified ProperName)+  | UnknownType (Qualified (ProperName 'TypeName))+  | UnknownTypeClass (Qualified (ProperName 'ClassName))   | UnknownValue (Qualified Ident)-  | UnknownDataConstructor (Qualified ProperName) (Maybe (Qualified ProperName))-  | UnknownTypeConstructor (Qualified ProperName)-  | UnknownImportType ModuleName ProperName-  | UnknownExportType ProperName-  | UnknownImportTypeClass ModuleName ProperName-  | UnknownExportTypeClass ProperName+  | UnknownDataConstructor (Qualified (ProperName 'ConstructorName)) (Maybe (Qualified (ProperName 'ConstructorName)))+  | UnknownTypeConstructor (Qualified (ProperName 'TypeName))+  | UnknownImportType ModuleName (ProperName 'TypeName)+  | UnknownExportType (ProperName 'TypeName)+  | UnknownImportTypeClass ModuleName (ProperName 'ClassName)+  | UnknownExportTypeClass (ProperName 'ClassName)   | UnknownImportValue ModuleName Ident   | UnknownExportValue Ident   | UnknownExportModule ModuleName-  | UnknownImportDataConstructor ModuleName ProperName ProperName-  | UnknownExportDataConstructor ProperName ProperName-  | ConflictingImport String ModuleName-  | ConflictingImports String ModuleName ModuleName-  | ConflictingTypeDecls ProperName-  | ConflictingCtorDecls ProperName-  | TypeConflictsWithClass ProperName-  | CtorConflictsWithClass ProperName-  | ClassConflictsWithType ProperName-  | ClassConflictsWithCtor ProperName+  | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName)+  | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName)+  | ScopeConflict String [ModuleName]+  | ConflictingTypeDecls (ProperName 'TypeName)+  | ConflictingCtorDecls (ProperName 'ConstructorName)+  | TypeConflictsWithClass (ProperName 'TypeName)+  | CtorConflictsWithClass (ProperName 'ConstructorName)+  | ClassConflictsWithType (ProperName 'ClassName)+  | ClassConflictsWithCtor (ProperName 'ClassName)   | DuplicateModuleName ModuleName-  | DuplicateClassExport ProperName+  | DuplicateClassExport (ProperName 'ClassName)   | DuplicateValueExport Ident   | DuplicateTypeArgument String   | InvalidDoBind   | InvalidDoLet   | CycleInDeclaration Ident-  | CycleInTypeSynonym (Maybe ProperName)+  | CycleInTypeSynonym (Maybe (ProperName 'TypeName))   | CycleInModules [ModuleName]   | NameIsUndefined Ident-  | UndefinedTypeVariable ProperName-  | PartiallyAppliedSynonym (Qualified ProperName)+  | UndefinedTypeVariable (ProperName 'TypeName)+  | PartiallyAppliedSynonym (Qualified (ProperName 'TypeName))   | EscapedSkolem (Maybe Expr)   | TypesDoNotUnify Type Type   | KindsDoNotUnify Kind Kind   | ConstrainedTypeUnified Type Type-  | OverlappingInstances (Qualified ProperName) [Type] [Qualified Ident]-  | NoInstanceFound (Qualified ProperName) [Type]-  | PossiblyInfiniteInstance (Qualified ProperName) [Type]-  | CannotDerive (Qualified ProperName) [Type]-  | CannotFindDerivingType ProperName+  | OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident]+  | NoInstanceFound (Qualified (ProperName 'ClassName)) [Type]+  | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]+  | CannotDerive (Qualified (ProperName 'ClassName)) [Type]+  | CannotFindDerivingType (ProperName 'TypeName)   | DuplicateLabel String (Maybe Expr)   | DuplicateValueDeclaration Ident   | ArgListLengthsDiffer Ident   | OverlappingArgNames (Maybe Ident)   | MissingClassMember Ident-  | ExtraneousClassMember Ident (Qualified ProperName)+  | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName))   | ExpectedType Type Kind-  | IncorrectConstructorArity (Qualified ProperName)+  | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName))   | ExprDoesNotHaveType Expr Type   | PropertyIsMissing String   | AdditionalProperty String   | CannotApplyFunction Type Expr   | TypeSynonymInstance-  | OrphanInstance Ident (Qualified ProperName) [Type]-  | InvalidNewtype ProperName+  | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type]+  | InvalidNewtype (ProperName 'TypeName)   | InvalidInstanceHead Type   | TransitiveExportError DeclarationRef [DeclarationRef]   | ShadowedName Ident@@ -134,13 +120,28 @@   | NotExhaustivePattern [[Binder]] Bool   | OverlappingPattern [[Binder]] Bool   | IncompleteExhaustivityCheck-  | ClassOperator ProperName Ident-  | MisleadingEmptyTypeImport ModuleName ProperName+  | ClassOperator (ProperName 'ClassName) Ident+  | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName)   | ImportHidingModule ModuleName   | UnusedImport ModuleName-  | UnusedExplicitImport ModuleName [String]-  | UnusedDctorImport ProperName-  | UnusedDctorExplicitImport ProperName [ProperName]+  | UnusedExplicitImport ModuleName [String] (Maybe ModuleName) [DeclarationRef]+  | UnusedDctorImport (ProperName 'TypeName)+  | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName]+  | DeprecatedOperatorDecl String+  | DeprecatedQualifiedSyntax ModuleName ModuleName+  | DeprecatedClassImport ModuleName (ProperName 'ClassName)+  | DeprecatedClassExport (ProperName 'ClassName)+  | RedundantUnqualifiedImport ModuleName ImportDeclarationType+  | DuplicateSelectiveImport ModuleName+  | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)+  | DuplicateImportRef String+  | DuplicateExportRef String+  | IntOutOfRange Integer String Integer Integer+  | RedundantEmptyHidingImport ModuleName+  | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef]+  | ImplicitImport ModuleName [DeclarationRef]+  | HidingImport ModuleName [DeclarationRef]+  | CaseBinderLengthDiffers Int [Binder]   deriving (Show)  -- | Error message hints, providing more detailed information about failure.@@ -148,7 +149,7 @@   = ErrorUnifyingTypes Type Type   | ErrorInExpression Expr   | ErrorInModule ModuleName-  | ErrorInInstance (Qualified ProperName) [Type]+  | ErrorInInstance (Qualified (ProperName 'ClassName)) [Type]   | ErrorInSubsumption Type Type   | ErrorCheckingAccessor Expr String   | ErrorCheckingType Expr Type@@ -156,11 +157,11 @@   | ErrorCheckingGuard   | ErrorInferringType Expr   | ErrorInApplication Expr Type Expr-  | ErrorInDataConstructor ProperName-  | ErrorInTypeConstructor ProperName+  | ErrorInDataConstructor (ProperName 'ConstructorName)+  | ErrorInTypeConstructor (ProperName 'TypeName)   | ErrorInBindingGroup [Ident]   | ErrorInDataBindingGroup-  | ErrorInTypeSynonym ProperName+  | ErrorInTypeSynonym (ProperName 'TypeName)   | ErrorInValueDeclaration Ident   | ErrorInTypeDeclaration Ident   | ErrorInForeignImport Ident@@ -178,6 +179,33 @@  data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage deriving (Show) +newtype ErrorSuggestion = ErrorSuggestion String++-- | Get the source span for an error+errorSpan :: ErrorMessage -> Maybe SourceSpan+errorSpan = findHint matchSpan+  where+  matchSpan (PositionedError ss) = Just ss+  matchSpan _ = Nothing++-- | Get the module name for an error+errorModule :: ErrorMessage -> Maybe ModuleName+errorModule = findHint matchModule+  where+  matchModule (ErrorInModule mn) = Just mn+  matchModule _ = Nothing++findHint :: (ErrorMessageHint -> Maybe a) -> ErrorMessage -> Maybe a+findHint f (ErrorMessage hints _) = getLast . foldMap (Last . f) $ hints++-- | Remove the module name and span hints from an error+stripModuleAndSpan :: ErrorMessage -> ErrorMessage+stripModuleAndSpan (ErrorMessage hints e) = ErrorMessage (filter (not . shouldStrip) hints) e+  where+  shouldStrip (ErrorInModule _) = True+  shouldStrip (PositionedError _) = True+  shouldStrip _ = False+ -- | -- Get the error code for a particular error type --@@ -214,8 +242,7 @@   UnknownExportModule{} -> "UnknownExportModule"   UnknownImportDataConstructor{} -> "UnknownImportDataConstructor"   UnknownExportDataConstructor{} -> "UnknownExportDataConstructor"-  ConflictingImport{} -> "ConflictingImport"-  ConflictingImports{} -> "ConflictingImports"+  ScopeConflict{} -> "ScopeConflict"   ConflictingTypeDecls{} -> "ConflictingTypeDecls"   ConflictingCtorDecls{} -> "ConflictingCtorDecls"   TypeConflictsWithClass{} -> "TypeConflictsWithClass"@@ -275,7 +302,21 @@   UnusedExplicitImport{} -> "UnusedExplicitImport"   UnusedDctorImport{} -> "UnusedDctorImport"   UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"-+  DeprecatedOperatorDecl{} -> "DeprecatedOperatorDecl"+  DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax"+  DeprecatedClassImport{} -> "DeprecatedClassImport"+  DeprecatedClassExport{} -> "DeprecatedClassExport"+  RedundantUnqualifiedImport{} -> "RedundantUnqualifiedImport"+  DuplicateSelectiveImport{} -> "DuplicateSelectiveImport"+  DuplicateImport{} -> "DuplicateImport"+  DuplicateImportRef{} -> "DuplicateImportRef"+  DuplicateExportRef{} -> "DuplicateExportRef"+  IntOutOfRange{} -> "IntOutOfRange"+  RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport"+  ImplicitQualifiedImport{} -> "ImplicitQualifiedImport"+  ImplicitImport{} -> "ImplicitImport"+  HidingImport{} -> "HidingImport"+  CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"  -- | -- A stack trace for an error@@ -293,7 +334,6 @@ errorMessage :: SimpleErrorMessage -> MultipleErrors errorMessage err = MultipleErrors [ErrorMessage [] err] - -- | -- Create an error set from a single error message --@@ -308,12 +348,17 @@ addHint :: ErrorMessageHint -> MultipleErrors -> MultipleErrors addHint hint = onErrorMessages $ \(ErrorMessage hints se) -> ErrorMessage (hint : hints) se --- | The various types of things which might need to be relabelled in errors messages.-data LabelType = TypeLabel | SkolemLabel String deriving (Show, Read, Eq, Ord)- -- | A map from rigid type variable name/unknown variable pairs to new variables.-type UnknownMap = M.Map (LabelType, Int) Int+data TypeMap = TypeMap+  { umSkolemMap :: M.Map Int (String, Int, Maybe SourceSpan)+  , umNextSkolem :: Int+  , umUnknownMap :: M.Map Int Int+  , umNextUnknown :: Int+  } deriving Show +defaultUnknownMap :: TypeMap+defaultUnknownMap = TypeMap M.empty 0 M.empty 0+ -- | How critical the issue is data Level = Error | Warning deriving Show @@ -323,56 +368,133 @@ unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage unwrapErrorMessage (ErrorMessage _ se) = se -replaceUnknowns :: Type -> State UnknownMap Type+replaceUnknowns :: Type -> State TypeMap Type replaceUnknowns = everywhereOnTypesM replaceTypes   where-  lookupTable :: (LabelType, Int) -> UnknownMap -> (Int, UnknownMap)-  lookupTable x m = case M.lookup x m of-                      Nothing -> let i = length (filter (on (==) fst x) (M.keys m)) in (i, M.insert x i m)-                      Just i  -> (i, m)--  replaceTypes :: Type -> State UnknownMap Type-  replaceTypes (TUnknown u) = state $ first TUnknown . lookupTable (TypeLabel, u)-  replaceTypes (Skolem name s sko) = state $ first (flip (Skolem name) sko) . lookupTable (SkolemLabel name, s)+  replaceTypes :: Type -> State TypeMap Type+  replaceTypes (TUnknown u) = do+    m <- get+    case M.lookup u (umUnknownMap m) of+      Nothing -> do+        let u' = umNextUnknown m+        put $ m { umUnknownMap = M.insert u u' (umUnknownMap m), umNextUnknown = u' + 1 }+        return (TUnknown u')+      Just u' -> return (TUnknown u')+  replaceTypes (Skolem name s sko ss) = do+    m <- get+    case M.lookup s (umSkolemMap m) of+      Nothing -> do+        let s' = umNextSkolem m+        put $ m { umSkolemMap = M.insert s (name, s', ss) (umSkolemMap m), umNextSkolem = s' + 1 }+        return (Skolem name s' sko ss)+      Just (_, s', _) -> return (Skolem name s' sko ss)   replaceTypes other = return other  onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint hints <*> gSimple simple   where-    gSimple (InfiniteType t) = InfiniteType <$> f t-    gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2-    gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2-    gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t-    gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e-    gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t-    gSimple other = pure other-    gHint (ErrorInSubsumption t1 t2) = ErrorInSubsumption <$> f t1 <*> f t2-    gHint (ErrorUnifyingTypes t1 t2) = ErrorUnifyingTypes <$> f t1 <*> f t2-    gHint (ErrorCheckingType e t) = ErrorCheckingType e <$> f t-    gHint (ErrorCheckingKind t) = ErrorCheckingKind <$> f t-    gHint (ErrorInApplication e1 t1 e2) = ErrorInApplication e1 <$> f t1 <*> pure e2-    gHint other = pure other+  gSimple (InfiniteType t) = InfiniteType <$> f t+  gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2+  gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2+  gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t+  gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e+  gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t+  gSimple (NoInstanceFound cl ts) = NoInstanceFound cl <$> traverse f ts+  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+  gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k+  gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts+  gSimple (WildcardInferredType ty) = WildcardInferredType <$> f ty+  gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty +  gSimple other = pure other++  gHint (ErrorInSubsumption t1 t2) = ErrorInSubsumption <$> f t1 <*> f t2+  gHint (ErrorUnifyingTypes t1 t2) = ErrorUnifyingTypes <$> f t1 <*> f t2+  gHint (ErrorCheckingType e t) = ErrorCheckingType e <$> f t+  gHint (ErrorCheckingKind t) = ErrorCheckingKind <$> f t+  gHint (ErrorInApplication e1 t1 e2) = ErrorInApplication e1 <$> f t1 <*> pure e2+  gHint (ErrorInInstance cl ts) = ErrorInInstance cl <$> traverse f ts+  gHint other = pure other++wikiUri :: ErrorMessage -> String+wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e++-- TODO Other possible suggestions:+-- WildcardInferredType - source span not small enough+-- DuplicateSelectiveImport - would require 2 ranges to remove and 1 insert+-- DeprecatedClassExport, DeprecatedClassImport,  would want to replace smaller span?+errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion+errorSuggestion err = case err of+  UnusedImport{} -> emptySuggestion+  RedundantEmptyHidingImport{} -> emptySuggestion+  DuplicateImport{} -> emptySuggestion+  RedundantUnqualifiedImport{} -> emptySuggestion+  DeprecatedQualifiedSyntax name qualName -> suggest $+    "import " ++ runModuleName name ++ " as " ++ runModuleName qualName+  UnusedExplicitImport 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)+  _ -> Nothing++  where+    emptySuggestion = Just $ ErrorSuggestion ""+    suggest = Just . ErrorSuggestion++    importSuggestion :: ModuleName -> [ DeclarationRef ] -> Maybe ModuleName -> String+    importSuggestion mn refs qual =+      "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")" ++ qstr qual++    qstr :: Maybe ModuleName -> String+    qstr (Just mn) = " as " ++ runModuleName mn+    qstr Nothing = ""++showSuggestion :: SimpleErrorMessage -> String+showSuggestion suggestion = case errorSuggestion suggestion of+  Just (ErrorSuggestion x) -> x+  _ -> ""+ -- | -- Pretty print a single error, simplifying if necessary ---prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State UnknownMap Box.Box-prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)+prettyPrintSingleError :: Bool -> Level -> Bool -> ErrorMessage -> Box.Box+prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap $ do+  em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)+  um <- get+  return (prettyPrintErrorMessage um em)   where    -- Pretty print an ErrorMessage-  prettyPrintErrorMessage :: ErrorMessage -> Box.Box-  prettyPrintErrorMessage (ErrorMessage hints simple) =+  prettyPrintErrorMessage :: TypeMap -> ErrorMessage -> Box.Box+  prettyPrintErrorMessage typeMap (ErrorMessage hints simple) =     paras $       [ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints-      , Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri ++ " for more information, "-                               , line $ "or to contribute content related to this " ++ levelText ++ "."-                               ]+      ] +++      maybe [] (return . Box.moveDown 1) typeInformation +++      [ Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri e ++ " for more information, "+                                 , line $ "or to contribute content related to this " ++ levelText ++ "."+                                 ]+      | showWiki       ]     where-    wikiUri :: String-    wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e+    typeInformation :: Maybe Box.Box+    typeInformation | not (null types) = Just $ Box.hsep 1 Box.left [ line "where", paras types ]+                    | otherwise = Nothing+      where+      types :: [Box.Box]+      types = map skolemInfo  (M.elems (umSkolemMap typeMap)) +++              map unknownInfo (M.elems (umUnknownMap typeMap)) +      skolemInfo :: (String, Int, Maybe SourceSpan) -> Box.Box+      skolemInfo (name, s, ss) =+        paras $+          line (name ++ show s ++ " is a rigid type variable")+          : foldMap (return . line . ("  bound at " ++) . displayStartEndPos) ss++      unknownInfo :: Int -> Box.Box+      unknownInfo u = line $ "_" ++ show u ++ " is an unknown type"+     renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box     renderSimpleErrorMessage (CannotGetFileInfo path) =       paras [ line "Unable to read file info: "@@ -469,13 +591,10 @@       line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon     renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =       line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ ", as it has not been declared."-    renderSimpleErrorMessage (ConflictingImport nm mn) =-      paras [ line $ "Cannot declare " ++ show nm ++ ", since another declaration of that name was imported from module " ++ runModuleName mn-            , line $ "Consider hiding " ++ show nm ++ " when importing " ++ runModuleName mn ++ ":"-            , indent . line $ "import " ++ runModuleName mn ++ " hiding (" ++ nm ++ ")"+    renderSimpleErrorMessage (ScopeConflict nm ms) =+      paras [ line $ "Conflicting definitions are in scope for " ++ nm ++ " from the following modules:"+            , indent $ paras $ map (line . runModuleName) ms             ]-    renderSimpleErrorMessage (ConflictingImports nm m1 m2) =-      line $ "Conflicting imports for " ++ nm ++ " from modules " ++ runModuleName m1 ++ " and " ++ runModuleName m2     renderSimpleErrorMessage (ConflictingTypeDecls nm) =       line $ "Conflicting type declarations for " ++ runProperName nm     renderSimpleErrorMessage (ConflictingCtorDecls nm) =@@ -520,12 +639,31 @@                      <> foldMap (\expr -> [ line "Relevant expression: "                                           , indent $ prettyPrintValue valueDepth expr                                           ]) binding-    renderSimpleErrorMessage (TypesDoNotUnify t1 t2)-      = paras [ line "Could not match type"-              , indent $ typeAsBox t1-              , line "with type"-              , indent $ typeAsBox t2-              ]+    renderSimpleErrorMessage (TypesDoNotUnify u1 u2)+      = let (sorted1, sorted2) = sortRows u1 u2++            sortRows :: Type -> Type -> (Type, Type)+            sortRows r1@RCons{} r2@RCons{} = sortRows' (rowToList r1) (rowToList r2)+            sortRows t1 t2 = (t1, t2)++            -- Put the common labels last+            sortRows' :: ([(String, Type)], Type) -> ([(String, Type)], Type) -> (Type, Type)+            sortRows' (s1, r1) (s2, r2) =+              let common :: [(String, (Type, Type))]+                  common = sortBy (comparing fst) $ [ (name, (t1, t2)) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]++                  sd1, sd2 :: [(String, Type)]+                  sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]+                  sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]+              in ( rowFromList (sortBy (comparing fst) sd1 ++ map (fst &&& fst . snd) common, r1)+                 , rowFromList (sortBy (comparing fst) sd2 ++ map (fst &&& snd . snd) common, r2)+                 )+        in paras [ line "Could not match type"+                 , indent $ typeAsBox sorted1+                 , line "with type"+                 , indent $ typeAsBox sorted2+                 ]+     renderSimpleErrorMessage (KindsDoNotUnify k1 k2) =       paras [ line "Could not match kind"             , indent $ line $ prettyPrintKind k1@@ -554,7 +692,16 @@             , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)                                            , Box.vcat Box.left (map typeAtomAsBox ts)                                            ]+            , paras [ line "The instance head contains unknown type variables. Consider adding a type annotation."+                    | any containsUnknowns ts+                    ]             ]+      where+      containsUnknowns :: Type -> Bool+      containsUnknowns = everythingOnTypes (||) go+        where+        go TUnknown{} = True+        go _ = False     renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =       paras [ line "Type class instance for"             , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)@@ -634,8 +781,9 @@             , line "All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form."             ]     renderSimpleErrorMessage (TransitiveExportError x ys) =-      paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")-              : map (line . prettyPrintExport) ys+      paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: "+            , indent $ paras $ map (line . prettyPrintExport) ys+            ]     renderSimpleErrorMessage (ShadowedName nm) =       line $ "Name '" ++ showIdent nm ++ "' was shadowed."     renderSimpleErrorMessage (ShadowedTypeVar tv) =@@ -666,9 +814,12 @@     renderSimpleErrorMessage (NotExhaustivePattern bs b) =       paras $ [ line "A case expression could not be determined to cover all inputs."               , line "The following additional cases are required to cover all inputs:\n"-              , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))-              ] ++-              [ line "..." | not b ]+              , indent $ paras $+                  [ Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ]+                  ++ [ line "..." | not b ]+              , line "Or alternatively, add a Partial constraint to the type of the enclosing value."+              , line "Non-exhaustive patterns for values without a `Partial` constraint will be disallowed in PureScript 0.9."+              ]     renderSimpleErrorMessage (OverlappingPattern bs b) =       paras $ [ line "A case expression contains unreachable cases:\n"               , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))@@ -681,9 +832,11 @@     renderSimpleErrorMessage (UnusedImport name) =       line $ "The import of module " ++ runModuleName name ++ " is redundant" -    renderSimpleErrorMessage (UnusedExplicitImport name names) =-      paras [ line $ "The import of module " ++ runModuleName name ++ " contains the following unused references:"-            , indent $ paras $ map line names ]+    renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) =+      paras [ line $ "The import of module " ++ runModuleName mn ++ " contains the following unused references:"+            , indent $ paras $ map line names+            , line $ "It could be replaced with:"+            , indent $ line $ showSuggestion msg ]      renderSimpleErrorMessage (UnusedDctorImport name) =       line $ "The import of type " ++ runProperName name ++ " includes data constructors but only the type is used"@@ -692,6 +845,80 @@       paras [ line $ "The import of type " ++ runProperName name ++ " includes the following unused data constructors:"             , indent $ paras $ map (line .runProperName) names ] +    renderSimpleErrorMessage (DeprecatedOperatorDecl name) =+      paras [ line $ "The operator (" ++ name ++ ") was declared as a value rather than an alias for a named function."+            , line "Operator aliases are declared by using a fixity declaration, for example:"+            , indent $ line $ "infixl 9 someFunction as " ++ name+            , line $ "Support for value-declared operators will be removed in PureScript 0.9."+            ]++    renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) =+      paras [ line $ "Import uses the deprecated 'qualified' syntax:"+            , indent $ line $ "import qualified " ++ runModuleName name ++ " as " ++ runModuleName qualName+            , line "Should instead use the form:"+            , indent $ line $ "import " ++ runModuleName name ++ " as " ++ runModuleName qualName+            , line $ "The deprecated syntax will be removed in PureScript 0.9."+            ]++    renderSimpleErrorMessage (DeprecatedClassImport mn name) =+      paras [ line $ "Class import from " ++ runModuleName mn ++ " uses deprecated syntax that omits the 'class' keyword:"+            , indent $ line $ runProperName name+            , line "Should instead use the form:"+            , indent $ line $ "class " ++ runProperName name+            , line $ "The deprecated syntax will be removed in PureScript 0.9."+            ]++    renderSimpleErrorMessage (DeprecatedClassExport name) =+      paras [ line $ "Class export uses deprecated syntax that omits the 'class' keyword:"+            , indent $ line $ runProperName name+            , line "Should instead use the form:"+            , indent $ line $ "class " ++ runProperName name+            , line $ "The deprecated syntax will be removed in PureScript 0.9."+            ]++    renderSimpleErrorMessage (RedundantUnqualifiedImport name imp) =+      line $ "Import of " ++ prettyPrintImport name imp Nothing ++ " is redundant due to a whole-module import"++    renderSimpleErrorMessage (DuplicateSelectiveImport name) =+      line $ "There is an existing import of " ++ runModuleName name ++ ", consider merging the import lists"++    renderSimpleErrorMessage (DuplicateImport name imp qual) =+      line $ "Duplicate import of " ++ prettyPrintImport name imp qual++    renderSimpleErrorMessage (DuplicateImportRef ref) =+      line $ "Import list contains multiple references to " ++ ref++    renderSimpleErrorMessage (DuplicateExportRef ref) =+      line $ "Export list contains multiple references to " ++ ref++    renderSimpleErrorMessage (IntOutOfRange value backend lo hi) =+      paras [ line $ "Integer value " ++ show value ++ " is out of range for the " ++ backend ++ " backend."+            , line $ "Acceptable values fall within the range " ++ show lo ++ " to " ++ show hi ++ " (inclusive)." ]++    renderSimpleErrorMessage (RedundantEmptyHidingImport mn) =+      line $ "The import for module " ++ runModuleName mn ++ " is redundant as all members have been explicitly hidden."++    renderSimpleErrorMessage msg@(ImplicitQualifiedImport importedModule asModule _) =+      paras [ line $ "Module " ++ runModuleName importedModule ++ " was imported as " ++ runModuleName asModule ++ " with unspecified imports."+            , line $ "As there are multiple modules being imported as " ++ runModuleName asModule ++ ", consider using the explicit form:"+            , indent $ line $ showSuggestion msg+            ]++    renderSimpleErrorMessage msg@(ImplicitImport mn _) =+      paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the explicit form: "+            , indent $ line $ showSuggestion msg+            ]++    renderSimpleErrorMessage (HidingImport mn refs) =+      paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the inclusive form: "+            , indent $ line $ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"+            ]++    renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) =+      paras $ [ line $ "Binder list length differs in case alternative:"+              , indent $ line $ intercalate ", " $ fmap prettyPrintBinderAtom bs+              , line $ "Expecting " ++ show l ++ " binder" ++ (if l == 1 then "" else "s") ++ "." ]+     renderHint :: ErrorMessageHint -> Box.Box -> Box.Box     renderHint (ErrorUnifyingTypes t1 t2) detail =       paras [ detail@@ -820,22 +1047,13 @@   paras :: [Box.Box] -> Box.Box   paras = Box.vcat Box.left -  -- Pretty print and export declaration-  prettyPrintExport :: DeclarationRef -> String-  prettyPrintExport (TypeRef pn _) = runProperName pn-  prettyPrintExport (ValueRef ident) = showIdent ident-  prettyPrintExport (TypeClassRef pn) = runProperName pn-  prettyPrintExport (TypeInstanceRef ident) = showIdent ident-  prettyPrintExport (ModuleRef name) = "module " ++ runModuleName name-  prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref-   -- | Simplify an error message   simplifyErrorMessage :: ErrorMessage -> ErrorMessage   simplifyErrorMessage (ErrorMessage hints simple) = ErrorMessage (simplifyHints hints) simple     where     -- Take the last instance of each "hint category"     simplifyHints :: [ErrorMessageHint] -> [ErrorMessageHint]-    simplifyHints = reverse . nubBy categoriesEqual . reverse+    simplifyHints = reverse . nubBy categoriesEqual . stripRedudantHints simple . reverse      -- Don't remove hints in the "other" category     categoriesEqual :: ErrorMessageHint -> ErrorMessageHint -> Bool@@ -845,6 +1063,30 @@         (_, OtherHint) -> False         (c1, c2) -> c1 == c2 +    -- | See https://github.com/purescript/purescript/issues/1802+    stripRedudantHints :: SimpleErrorMessage -> [ErrorMessageHint] -> [ErrorMessageHint]+    stripRedudantHints CannotApplyFunction{} = stripFirst isApplicationHint+      where+      isApplicationHint ErrorInApplication{} = True+      isApplicationHint _ = False+    stripRedudantHints ExprDoesNotHaveType{} = stripFirst isCheckHint+      where+      isCheckHint ErrorCheckingType{} = True+      isCheckHint _ = False+    stripRedudantHints TypesDoNotUnify{} = stripFirst isUnifyHint+      where+      isUnifyHint ErrorUnifyingTypes{} = True+      isUnifyHint _ = False+    stripRedudantHints _ = id++    stripFirst :: (ErrorMessageHint -> Bool) -> [ErrorMessageHint] -> [ErrorMessageHint]+    stripFirst p (PositionedError pos : hs) = PositionedError pos : stripFirst p hs+    stripFirst p (ErrorInModule mn    : hs) = ErrorInModule mn    : stripFirst p hs+    stripFirst p (hint                : hs)+      | p hint = hs+      | otherwise = hint : hs+    stripFirst _ [] = []+   hintCategory :: ErrorMessageHint -> HintCategory   hintCategory ErrorCheckingType{}  = ExprHint   hintCategory ErrorInferringType{} = ExprHint@@ -852,9 +1094,34 @@   hintCategory ErrorUnifyingTypes{} = CheckHint   hintCategory ErrorInSubsumption{} = CheckHint   hintCategory ErrorInApplication{} = CheckHint+  hintCategory ErrorCheckingKind{}  = CheckHint   hintCategory PositionedError{}    = PositionHint   hintCategory _                    = OtherHint +-- Pretty print and export declaration+prettyPrintExport :: DeclarationRef -> String+prettyPrintExport (TypeRef pn _) = runProperName pn+prettyPrintExport ref = prettyPrintRef ref++prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String+prettyPrintImport mn idt qual =+  let i = case idt of+            Implicit -> runModuleName mn+            Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"+            Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (map prettyPrintRef refs) ++ ")"+  in i ++ maybe "" (\q -> " as " ++ runModuleName q) qual++prettyPrintRef :: DeclarationRef -> String+prettyPrintRef (TypeRef pn Nothing) = runProperName pn ++ "(..)"+prettyPrintRef (TypeRef pn (Just [])) = runProperName pn+prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")"+prettyPrintRef (ValueRef ident) = showIdent ident+prettyPrintRef (TypeClassRef pn) = "class " ++ runProperName pn+prettyPrintRef (ProperRef name) = name+prettyPrintRef (TypeInstanceRef ident) = showIdent ident+prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name+prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref+ -- | -- Pretty print multiple errors --@@ -869,22 +1136,21 @@  -- | Pretty print warnings as a Box prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> Box.Box-prettyPrintMultipleWarningsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full+prettyPrintMultipleWarningsBox full = prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full  -- | Pretty print errors as a Box prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> Box.Box-prettyPrintMultipleErrorsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Error "Error found:" "Error" full+prettyPrintMultipleErrorsBox full = prettyPrintMultipleErrorsWith Error "Error found:" "Error" full -prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State UnknownMap Box.Box-prettyPrintMultipleErrorsWith level intro _ full  (MultipleErrors [e]) = do-  result <- prettyPrintSingleError full level e-  return $-    Box.vcat Box.left [ Box.text intro-                      , result-                      ]-prettyPrintMultipleErrorsWith level _ intro full  (MultipleErrors es) = do-  result <- forM es $ prettyPrintSingleError full level-  return $ Box.vsep 1 Box.left $ concat $ zipWith withIntro [1 :: Int ..] result+prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> Box.Box+prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) =+  let result = prettyPrintSingleError full level True e+  in Box.vcat Box.left [ Box.text intro+                       , result+                       ]+prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) =+  let result = map (prettyPrintSingleError full level True) es+  in Box.vsep 1 Box.left $ concat $ zipWith withIntro [1 :: Int ..] result   where   withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":")                     , Box.moveRight 2 err@@ -946,9 +1212,15 @@ line = Box.text  renderBox :: Box.Box -> String-renderBox = unlines . map trimEnd . lines . Box.render+renderBox = unlines+            . map (dropWhileEnd isSpace)+            . dropWhile whiteSpace+            . dropWhileEnd whiteSpace+            . lines+            . Box.render   where-  trimEnd = reverse . dropWhile (== ' ') . reverse+  dropWhileEnd p = reverse . dropWhile p . reverse+  whiteSpace = all isSpace  -- | -- Rethrow an error with a more detailed error message in the case of failure
src/Language/PureScript/Externs.hs view
@@ -1,22 +1,10 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Externs--- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess--- License     :  MIT (http://opensource.org/licenses/MIT)------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations.---------------------------------------------------------------------------------- {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TemplateHaskell #-} +-- |+-- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations.+-- module Language.PureScript.Externs   ( ExternsFile(..)   , ExternsImport(..)@@ -84,27 +72,29 @@   , efPrecedence :: Precedence   -- | The operator symbol   , efOperator :: String+  -- | The value the operator is an alias for+  , efAlias :: Maybe (Qualified Ident)   } deriving (Show, Read)  -- | A type or value declaration appearing in an externs file data ExternsDeclaration =   -- | A type declaration     EDType-      { edTypeName :: ProperName+      { edTypeName :: ProperName 'TypeName       , edTypeKind :: Kind       , edTypeDeclarationKind :: TypeKind       }   -- | A type synonym   | EDTypeSynonym-      { edTypeSynonymName :: ProperName+      { edTypeSynonymName :: ProperName 'TypeName       , edTypeSynonymArguments :: [(String, Maybe Kind)]       , edTypeSynonymType :: Type       }   -- | A data construtor   | EDDataConstructor-      { edDataCtorName :: ProperName+      { edDataCtorName :: ProperName 'ConstructorName       , edDataCtorOrigin :: DataDeclType-      , edDataCtorTypeCtor :: ProperName+      , edDataCtorTypeCtor :: ProperName 'TypeName       , edDataCtorType :: Type       , edDataCtorFields :: [Ident]       }@@ -115,14 +105,14 @@       }   -- | A type class declaration   | EDClass-      { edClassName :: ProperName+      { edClassName :: ProperName 'ClassName       , edClassTypeArguments :: [(String, Maybe Kind)]       , edClassMembers :: [(Ident, Type)]       , edClassConstraints :: [Constraint]       }   -- | An instance declaration   | EDInstance-      { edInstanceClassName :: Qualified ProperName+      { edInstanceClassName :: Qualified (ProperName 'ClassName)       , edInstanceName :: Ident       , edInstanceTypes :: [Type]       , edInstanceConstraints :: Maybe [Constraint]@@ -163,7 +153,7 @@   efDeclarations  = concatMap toExternsDeclaration efExports    fixityDecl :: Declaration -> Maybe ExternsFixity-  fixityDecl (FixityDeclaration (Fixity assoc prec) op) = fmap (const (ExternsFixity assoc prec op)) (find exportsOp exps)+  fixityDecl (FixityDeclaration (Fixity assoc prec) op alias) = fmap (const (ExternsFixity assoc prec op alias)) (find exportsOp exps)     where     exportsOp :: DeclarationRef -> Bool     exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r@@ -173,7 +163,7 @@   fixityDecl _ = Nothing    importDecl :: Declaration -> Maybe ExternsImport-  importDecl (ImportDeclaration m mt qmn) = Just (ExternsImport m mt qmn)+  importDecl (ImportDeclaration m mt qmn _) = Just (ExternsImport m mt qmn)   importDecl (PositionedDeclaration _ _ d) = importDecl d   importDecl _ = Nothing @@ -188,7 +178,7 @@       Just (kind, tk@(DataType _ tys)) ->         EDType pn kind tk : [ EDDataConstructor dctor dty pn ty args                             | dctor <- fromMaybe (map fst tys) dctors-                            , (dty, _, ty, args) <- maybeToList (M.lookup (Qualified (Just mn) dctor) (dataConstructors env))+                            , (dty, _, ty, args) <- maybeToList (Qualified (Just mn) dctor `M.lookup` dataConstructors env)                             ]       _ -> internalError "toExternsDeclaration: Invalid input"   toExternsDeclaration (ValueRef ident)@@ -196,10 +186,10 @@     = [ EDValue ident ty ]   toExternsDeclaration (TypeClassRef className)     | Just (args, members, implies) <- Qualified (Just mn) className `M.lookup` typeClasses env-    , Just (kind, TypeSynonym) <- M.lookup (Qualified (Just mn) className) (types env)-    , Just (_, synTy) <- Qualified (Just mn) className `M.lookup` typeSynonyms env-    = [ EDType className kind TypeSynonym-      , EDTypeSynonym className args synTy+    , Just (kind, TypeSynonym) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env+    , Just (_, synTy) <- Qualified (Just mn) (coerceProperName className) `M.lookup` typeSynonyms env+    = [ EDType (coerceProperName className) kind TypeSynonym+      , EDTypeSynonym (coerceProperName className) args synTy       , EDClass className args members implies       ]   toExternsDeclaration (TypeInstanceRef ident)
src/Language/PureScript/Kinds.hs view
@@ -1,18 +1,3 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Kinds--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |-----------------------------------------------------------------------------------{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-}  module Language.PureScript.Kinds where@@ -20,7 +5,6 @@ import Prelude () import Prelude.Compat -import Data.Data import qualified Data.Aeson.TH as A  -- |@@ -46,7 +30,8 @@   -- |   -- Function kinds   ---  | FunKind Kind Kind deriving (Show, Read, Eq, Ord, Data, Typeable)+  | FunKind Kind Kind+  deriving (Show, Read, Eq, Ord)  $(A.deriveJSON A.defaultOptions ''Kind)
src/Language/PureScript/Linter.hs view
@@ -1,26 +1,16 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Linter--- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess--- License     :  MIT (http://opensource.org/licenses/MIT)------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ | This module implements a simple linting pass on the PureScript AST.---------------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternGuards #-} +-- |+-- This module implements a simple linting pass on the PureScript AST.+-- module Language.PureScript.Linter (lint, module L) where  import Prelude () import Prelude.Compat -import Data.List (mapAccumL, nub, (\\))+import Data.List (nub, (\\)) import Data.Maybe (mapMaybe) import Data.Monoid @@ -54,43 +44,47 @@   getDeclIdent _ = Nothing    lintDeclaration :: Declaration -> m ()-  lintDeclaration d =-    let (f, _, _, _, _) = everythingWithContextOnValues moduleNames mempty mappend stepD stepE stepB def def--        f' :: Declaration -> MultipleErrors-        f' (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f' dec)-        f' dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (f dec <> checkTypeVarsInDecl dec)-        f' (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars ty)-        f' dec = f dec <> checkTypeVarsInDecl dec--    in tell (f' d)+  lintDeclaration = tell . f     where-    def s _ = (s, mempty)+    (warningsInDecl, _, _, _, _) = everythingWithScope stepD stepE stepB (\_ _ -> mempty) stepDo -    stepD :: S.Set Ident -> Declaration -> (S.Set Ident, MultipleErrors)-    stepD s (TypeClassDeclaration name _ _ decls) = (s, foldr go mempty decls)+    f :: Declaration -> MultipleErrors+    f (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f dec)+    f dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec)+    f (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars ty)+    f dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec++    stepD :: S.Set Ident -> Declaration -> MultipleErrors+    stepD _ (ValueDeclaration (Op name) _ _ _) = errorMessage (DeprecatedOperatorDecl name)+    stepD _ (TypeClassDeclaration _ _ _ decls) = foldMap go decls       where-      go :: Declaration -> MultipleErrors -> MultipleErrors-      go (PositionedDeclaration _ _ d') errs = go d' errs-      go (TypeDeclaration op@(Op _) _) errs = errorMessage (ClassOperator name op) <> errs-      go _ errs = errs-    stepD s _ = (s, mempty)+      go :: Declaration -> MultipleErrors+      go (PositionedDeclaration _ _ d') = go d'+      go (TypeDeclaration (Op name) _)  = errorMessage (DeprecatedOperatorDecl name)+      go _ = mempty+    stepD _ _ = mempty -    stepE :: S.Set Ident -> Expr -> (S.Set Ident, MultipleErrors)-    stepE s (Abs (Left name) _) = bindName s name-    stepE s (Let ds' _) =-      case mapAccumL bindName s (nub (mapMaybe getDeclIdent ds')) of-        (s', es) -> (s', mconcat es)-    stepE s _ = (s, mempty)+    stepE :: S.Set Ident -> Expr -> MultipleErrors+    stepE s (Abs (Left name) _) | name `S.member` s = errorMessage (ShadowedName name)+    stepE s (Let ds' _) = foldMap go ds'+      where+      go d | Just i <- getDeclIdent d+           , i `S.member` s = errorMessage (ShadowedName i)+           | otherwise = mempty+    stepE _ _ = mempty -    stepB :: S.Set Ident -> Binder -> (S.Set Ident, MultipleErrors)-    stepB s (VarBinder name) = bindName s name-    stepB s (NamedBinder name _) = bindName s name-    stepB s (TypedBinder _ b) = stepB s b-    stepB s _ = (s, mempty)+    stepB :: S.Set Ident -> Binder -> MultipleErrors+    stepB s (VarBinder name) | name `S.member` s = errorMessage (ShadowedName name)+    stepB s (NamedBinder name _) | name `S.member` s = errorMessage (ShadowedName name)+    stepB _ _ = mempty -    bindName :: S.Set Ident -> Ident -> (S.Set Ident, MultipleErrors)-    bindName = bind ShadowedName+    stepDo :: S.Set Ident -> DoNotationElement -> MultipleErrors+    stepDo s (DoNotationLet ds') = foldMap go ds'+      where+      go d | Just i <- getDeclIdent d+           , i `S.member` s = errorMessage (ShadowedName i)+           | otherwise = mempty+    stepDo _ _ = mempty    checkTypeVarsInDecl :: Declaration -> MultipleErrors   checkTypeVarsInDecl d = let (f, _, _, _, _) = accumTypes checkTypeVars in f d
src/Language/PureScript/Linter/Exhaustive.hs view
@@ -1,28 +1,13 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Exhaustive--- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess--- License     :  MIT (http://opensource.org/licenses/MIT)------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- | Module for exhaustivity checking over pattern matching definitions--- | The algorithm analyses the clauses of a definition one by one from top--- | to bottom, where in each step it has the cases already missing (uncovered),--- | and it generates the new set of missing cases.---------------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -module Language.PureScript.Linter.Exhaustive-  ( checkExhaustive-  , checkExhaustiveModule-  ) where+-- |+-- Module for exhaustivity checking over pattern matching definitions+-- The algorithm analyses the clauses of a definition one by one from top+-- to bottom, where in each step it has the cases already missing (uncovered),+-- and it generates the new set of missing cases.+--+module Language.PureScript.Linter.Exhaustive (checkExhaustiveModule) where  import Prelude () import Prelude.Compat@@ -46,18 +31,22 @@ import Language.PureScript.Types as P import Language.PureScript.Errors --- | There are two modes of failure for the redudancy check:+-- | There are two modes of failure for the redundancy check: ----- 1. Exhaustivity was incomeplete due to too many cases, so we couldn't determine redundancy.+-- 1. Exhaustivity was incomplete due to too many cases, so we couldn't determine redundancy. -- 2. We didn't attempt to determine redundancy for a binder, e.g. an integer binder. -- -- We want to warn the user in the first case.-data RedudancyError = Incomplete | Unknown+data RedundancyError = Incomplete | Unknown  -- | -- Qualifies a propername from a given qualified propername and a default module name ---qualifyName :: a -> ModuleName -> Qualified a -> Qualified a+qualifyName+  :: (ProperName a)+  -> ModuleName+  -> Qualified (ProperName b)+  -> Qualified (ProperName a) qualifyName n defmn qn = Qualified (Just mn) n   where   (mn, _) = qualify defmn qn@@ -68,32 +57,29 @@ -- where: - ProperName is the name of the constructor (for example, "Nothing" in Maybe) --        - [Type] is the list of arguments, if it has (for example, "Just" has [TypeVar "a"]) ---getConstructors :: Environment -> ModuleName -> Qualified ProperName -> [(ProperName, [Type])]+getConstructors :: Environment -> ModuleName -> Qualified (ProperName 'ConstructorName) -> [(ProperName 'ConstructorName, [Type])] getConstructors env defmn n = extractConstructors lnte   where-  qpn :: Qualified ProperName-  qpn = getConsDataName n -  getConsDataName :: Qualified ProperName -> Qualified ProperName-  getConsDataName con = qualifyName nm defmn con-    where-    nm = case getConsInfo con of-           Nothing -> error $ "Constructor " ++ showQualified runProperName con ++ " not in the scope of the current environment in getConsDataName."-           Just (_, pm, _, _) -> pm--  getConsInfo :: Qualified ProperName -> Maybe (DataDeclType, ProperName, Type, [Ident])-  getConsInfo con = M.lookup con dce-    where-    dce :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident])-    dce = dataConstructors env+  extractConstructors :: Maybe (Kind, TypeKind) -> [(ProperName 'ConstructorName, [Type])]+  extractConstructors (Just (_, DataType _ pt)) = pt+  extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors"    lnte :: Maybe (Kind, TypeKind)   lnte = M.lookup qpn (types env) -  extractConstructors :: Maybe (Kind, TypeKind) -> [(ProperName, [Type])]-  extractConstructors (Just (_, DataType _ pt)) = pt-  extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors"+  qpn :: Qualified (ProperName 'TypeName)+  qpn = getConsDataName n +  getConsDataName :: Qualified (ProperName 'ConstructorName) -> Qualified (ProperName 'TypeName)+  getConsDataName con =+    case getConsInfo con of+      Nothing -> internalError $ "Constructor " ++ showQualified runProperName con ++ " not in the scope of the current environment in getConsDataName."+      Just (_, pm, _, _) -> qualifyName pm defmn con++  getConsInfo :: Qualified (ProperName 'ConstructorName) -> Maybe (DataDeclType, ProperName 'TypeName, Type, [Ident])+  getConsInfo con = M.lookup con (dataConstructors env)+ -- | -- Replicates a wildcard binder --@@ -120,7 +106,7 @@ -- Find the uncovered set between two binders: -- the first binder is the case we are trying to cover, the second one is the matching binder ---missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedudancyError Bool)+missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedundancyError Bool) missingCasesSingle _ _ _ NullBinder = ([], return True) missingCasesSingle _ _ _ (VarBinder _) = ([], return True) missingCasesSingle env mn (VarBinder _) b = missingCasesSingle env mn NullBinder b@@ -189,7 +175,7 @@ --       redundant or not, but uncovered at least. If we use `y` instead, we'll need to have a redundancy checker --       (which ought to be available soon), or increase the complexity of the algorithm. ---missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedudancyError Bool)+missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedundancyError Bool) missingCasesMultiple env mn = go   where   go [] [] = ([], pure True)@@ -217,16 +203,17 @@   isOtherwise :: Expr -> Bool   isOtherwise (TypedValue _ (BooleanLiteral True) _) = True   isOtherwise (TypedValue _ (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) _) = True+  isOtherwise (TypedValue _ (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) _) = True   isOtherwise _ = False isExhaustiveGuard (Right _) = True  -- | -- Returns the uncovered set of case alternatives ---missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedudancyError Bool)+missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedundancyError Bool) missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca) -missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedudancyError Bool)+missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedundancyError Bool) missingAlternative env mn ca uncovered   | isExhaustiveGuard (caseAlternativeResult ca) = mcases   | otherwise = ([uncovered], snd mcases)@@ -239,16 +226,16 @@ -- it partitions that set with the new uncovered cases, until it consumes the whole set of clauses. -- Then, returns the uncovered set of case alternatives. ---checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()-checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas+checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Bool -> Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()+checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas   where-  step :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedudancyError Bool, [[Binder]]))+  step :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedundancyError Bool, [[Binder]]))   step (uncovered, (nec, redundant)) ca =     let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered)         (missed', approx) = splitAt 10000 (nub (concat missed))-        cond = liftA2 (&&) (or <$> sequenceA pr) nec+        cond = or <$> sequenceA pr     in (missed', ( if null approx-                     then cond+                     then liftA2 (&&) cond nec                      else Left Incomplete                  , if either (const True) id cond                      then redundant@@ -256,15 +243,15 @@                  )        ) -  makeResult :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> m ()+  makeResult :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> m ()   makeResult (bss, (rr, bss')) =-    do unless (null bss) tellExhaustive+    do unless (hasConstraint || null bss) tellNonExhaustive        unless (null bss') tellRedundant        case rr of-         Left Incomplete -> tellIncomplete+         Left Incomplete -> unless hasConstraint tellIncomplete          _ -> return ()     where-    tellExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss+    tellNonExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss     tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss'     tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck @@ -279,29 +266,43 @@     where     convert :: (Ident, NameKind, Expr) -> Declaration     convert (name, nk, e) = ValueDeclaration name nk [] (Right e)-  onDecl (ValueDeclaration name _ _ (Right e)) = censor (addHint (ErrorInValueDeclaration name)) (onExpr e)+  onDecl (ValueDeclaration name _ _ (Right e)) = censor (addHint (ErrorInValueDeclaration name)) (onExpr False e)   onDecl (PositionedDeclaration pos _ dec) = censor (addHint (PositionedError pos)) (onDecl dec)   onDecl _ = return () -  onExpr :: Expr -> m ()-  onExpr (UnaryMinus e) = onExpr e-  onExpr (ArrayLiteral es) = mapM_ onExpr es-  onExpr (ObjectLiteral es) = mapM_ (onExpr . snd) es-  onExpr (TypeClassDictionaryConstructorApp _ e) = onExpr e-  onExpr (Accessor _ e) = onExpr e-  onExpr (ObjectUpdate o es) = onExpr o >> mapM_ (onExpr . snd) es-  onExpr (Abs _ e) = onExpr e-  onExpr (App e1 e2) = onExpr e1 >> onExpr e2-  onExpr (IfThenElse e1 e2 e3) = onExpr e1 >> onExpr e2 >> onExpr e3-  onExpr (Case es cas) = checkExhaustive env mn (length es) cas >> mapM_ onExpr es >> mapM_ onCaseAlternative cas-  onExpr (TypedValue _ e _) = onExpr e-  onExpr (Let ds e) = mapM_ onDecl ds >> onExpr e-  onExpr (PositionedValue pos _ e) = censor (addHint (PositionedError pos)) (onExpr e)-  onExpr _ = return ()+  onExpr :: Bool -> Expr -> m ()+  onExpr isP (UnaryMinus e) = onExpr isP e+  onExpr isP (ArrayLiteral es) = mapM_ (onExpr isP) es+  onExpr isP (ObjectLiteral es) = mapM_ (onExpr isP . snd) es+  onExpr isP (TypeClassDictionaryConstructorApp _ e) = onExpr isP e+  onExpr isP (Accessor _ e) = onExpr isP e+  onExpr isP (ObjectUpdate o es) = onExpr isP o >> mapM_ (onExpr isP . snd) es+  onExpr isP (Abs _ e) = onExpr isP e+  onExpr isP (App e1 e2) = onExpr isP e1 >> onExpr isP e2+  onExpr isP (IfThenElse e1 e2 e3) = onExpr isP e1 >> onExpr isP e2 >> onExpr isP e3+  onExpr isP (Case es cas) = checkExhaustive isP env mn (length es) cas >> mapM_ (onExpr isP) es >> mapM_ (onCaseAlternative isP) cas+  onExpr isP (TypedValue _ e ty) = onExpr (isP || hasPartialConstraint ty) e+  onExpr isP (Let ds e) = mapM_ onDecl ds >> onExpr isP e+  onExpr isP (PositionedValue pos _ e) = censor (addHint (PositionedError pos)) (onExpr isP e)+  onExpr _ _ = return () -  onCaseAlternative :: CaseAlternative -> m ()-  onCaseAlternative (CaseAlternative _ (Left es)) = mapM_ (\(e, g) -> onExpr e >> onExpr g) es-  onCaseAlternative (CaseAlternative _ (Right e)) = onExpr e+  onCaseAlternative :: Bool -> CaseAlternative -> m ()+  onCaseAlternative isP (CaseAlternative _ (Left es)) = mapM_ (\(e, g) -> onExpr isP e >> onExpr isP g) es+  onCaseAlternative isP (CaseAlternative _ (Right e)) = onExpr isP e++  hasPartialConstraint :: Type -> Bool+  hasPartialConstraint (ConstrainedType cs _) = any (go . fst) cs+    where+    go :: Qualified (ProperName 'ClassName) -> Bool+    go qname+      | qname == partialClass = True+      | otherwise =+          case qname `M.lookup` typeClasses env of+            Just ([], _, cs') -> any (go . fst) cs'+            _ -> False+    partialClass :: Qualified (ProperName 'ClassName)+    partialClass = primName "Partial"+  hasPartialConstraint _ = False  -- | -- Exhaustivity checking over a single module
src/Language/PureScript/Linter/Imports.hs view
@@ -1,21 +1,27 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} -module Language.PureScript.Linter.Imports (findUnusedImports, Name(..), UsedImports()) where+module Language.PureScript.Linter.Imports+  ( lintImports+  , Name(..)+  , UsedImports()+  ) where  import Prelude () import Prelude.Compat -import qualified Data.Map as M-import Data.Maybe (mapMaybe)-import Data.List ((\\), find, intersect)+import Control.Monad (unless, when) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class-import Control.Monad(unless,when)+ import Data.Foldable (forM_)+import Data.List ((\\), find, intersect, nub)+import Data.Maybe (mapMaybe)+import qualified Data.Map as M  import Language.PureScript.AST.Declarations import Language.PureScript.AST.SourcePos+import Language.PureScript.Crash import Language.PureScript.Names as P  import Language.PureScript.Errors@@ -25,88 +31,273 @@ import qualified Language.PureScript.Constants as C  -- | Imported name used in some type or expression.-data Name = IdentName (Qualified Ident) | IsProperName (Qualified ProperName) | DctorName (Qualified ProperName)+data Name+  = IdentName (Qualified Ident)+  | TyName (Qualified (ProperName 'TypeName))+  | DctorName (Qualified (ProperName 'ConstructorName))+  | TyClassName (Qualified (ProperName 'ClassName))+  deriving (Eq, Show) +getIdentName :: Maybe ModuleName -> Name -> Maybe Ident+getIdentName q (IdentName (Qualified q' name)) | q == q' = Just name+getIdentName _ _ = Nothing++getTypeName :: Maybe ModuleName -> Name -> Maybe (ProperName 'TypeName)+getTypeName q (TyName (Qualified q' name)) | q == q' = Just name+getTypeName _ _ = Nothing++getClassName :: Maybe ModuleName -> Name -> Maybe (ProperName 'ClassName)+getClassName q (TyClassName (Qualified q' name)) | q == q' = Just name+getClassName _ _ = Nothing+ -- | Map of module name to list of imported names from that module which have been used. type UsedImports = M.Map ModuleName [Name]  -- |--- Find and warn on any unused import statements (qualified or unqualified)--- or references in an explicit import list.+-- Find and warn on: ---findUnusedImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> Env -> UsedImports -> m ()-findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do-  imps <- findImports mdecls-  forM_ (M.toAscList imps) $ \(mni, decls) -> unless (mni `elem` alwaysUsedModules) $-    forM_ decls $ \(ss, declType, qualifierName) ->-      censor (onErrorMessages $ addModuleLocError ss) $ unless (qnameUsed qualifierName) $-        let names = sugarNames mni ++ M.findWithDefault [] mni usedImps-            usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names-            usedDctors = mapMaybe (matchDctor qualifierName) names-        in case declType of-          Implicit -> when (null usedNames) $ tell $ errorMessage $ UnusedImport mni-          Explicit declrefs -> do-            let idents = mapMaybe runDeclRef declrefs-            let diff = idents \\ usedNames-            case (length diff, length idents) of-              (0, _) -> return ()-              (n, m) | n == m -> tell $ errorMessage $ UnusedImport mni-              _ -> tell $ errorMessage $ UnusedExplicitImport mni diff+-- * Unused import statements (qualified or unqualified)+--+-- * Unused references in an explicit import list+--+-- * Implicit imports of modules+--+-- * Implicit imports into a virtual module (unless the virtual module only has+--   members from one module imported)+--+-- * Imports using `hiding` (this is another form of implicit importing)+--+lintImports+  :: forall m+   . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)+  => Module+  -> Env+  -> UsedImports+  -> m ()+lintImports (Module _ _ mn mdecls mexports) env usedImps = do -            -- If we've not already warned a type is unused, check its data constructors-            forM_ (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do-              let allCtors = dctorsForType mni tn-              when (runProperName tn `elem` usedNames) $ case (c, null $ usedDctors `intersect` allCtors) of-                (Nothing, True) -> tell $ errorMessage $ UnusedDctorImport tn-                (Just (_:_), True) -> tell $ errorMessage $ UnusedDctorImport tn-                (Just ctors, _) ->-                  let ddiff = ctors \\ usedDctors-                  in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff-                _ -> return ()-            return ()+  let scope = maybe nullImports (\(_, imps, _) -> imps) (M.lookup mn env)+      usedImps' = foldr (elaborateUsed scope) usedImps exportedModules -          _ -> return ()+  imps <- M.toAscList <$> findImports mdecls++  forM_ imps $ \(mni, decls) ->+    unless (isPrim mni) $ do+      forM_ decls $ \(ss, declType, qualifierName) ->+        censor (onErrorMessages $ addModuleLocError ss) $ do+          let names = nub $ M.findWithDefault [] mni usedImps'+          lintImportDecl env mni qualifierName names declType++  forM_ (M.toAscList (byQual imps)) $ \(mnq, entries) -> do+    let mnis = nub $ map (\(_, _, mni) -> mni) entries+    unless (length mnis == 1) $ do+      let implicits = filter (\(_, declType, _) -> not $ isExplicit declType) entries+      forM_ implicits $ \(ss, _, mni) ->+        censor (onErrorMessages $ addModuleLocError ss) $ do+          let names = nub $ M.findWithDefault [] mni usedImps'+              usedRefs = findUsedRefs env mni (Just mnq) names+          unless (null usedRefs) $+            tell $ errorMessage $ ImplicitQualifiedImport mni mnq usedRefs++  return ()+   where-  sugarNames :: ModuleName -> [ Name ]-  sugarNames (ModuleName [ProperName n]) | n == C.prelude = [ IdentName $ Qualified Nothing (Ident C.bind) ]-  sugarNames _ = [] -  -- rely on exports being elaborated by this point-  alwaysUsedModules :: [ ModuleName ]-  alwaysUsedModules = ModuleName [ProperName C.prim] : maybe [] (mapMaybe isExport) mexports+  -- Checks whether a module is the Prim module - used to suppress any checks+  -- made, as Prim is always implicitly imported.+  isPrim :: ModuleName -> Bool+  isPrim = (== ModuleName [ProperName C.prim])++  -- Creates a map of virtual modules mapped to all the declarations that+  -- import to that module, with the corresponding source span, import type,+  -- and module being imported+  byQual+    :: [(ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])]+    -> M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, ModuleName)]+  byQual = foldr goImp M.empty     where-      isExport (ModuleRef mn) = Just mn-      isExport _ = Nothing+    goImp (mni, xs) acc = foldr (goDecl mni) acc xs+    goDecl mni (ss, declType, Just qmn) acc =+      let entry = (ss, declType, mni)+      in M.alter (Just . maybe [entry] (entry :)) qmn acc+    goDecl _ _ acc = acc -  qnameUsed :: Maybe ModuleName -> Bool-  qnameUsed (Just qn) = qn `elem` alwaysUsedModules-  qnameUsed Nothing = False+  -- The list of modules that are being re-exported by the current module. Any+  -- module that appears in this list is always considered to be used.+  exportedModules :: [ModuleName]+  exportedModules = nub $ maybe [] (mapMaybe extractModule) mexports+    where+    extractModule (PositionedDeclarationRef _ _ r) = extractModule r+    extractModule (ModuleRef mne) = Just mne+    extractModule _ = Nothing -  dtys :: ModuleName -> [((ProperName, [ProperName]), ModuleName)]+  -- Elaborates the UsedImports to include values from modules that are being+  -- re-exported. This ensures explicit export hints are printed for modules+  -- that are implicitly exported and then re-exported.+  elaborateUsed :: Imports -> ModuleName -> UsedImports -> UsedImports+  elaborateUsed scope mne used =+    let classes = extractByQual mne (importedTypeClasses scope) TyClassName+        types = extractByQual mne (importedTypes scope) TyName+        dctors = extractByQual mne (importedDataConstructors scope) DctorName+        values = extractByQual mne (importedValues scope) IdentName+    in foldr go used (classes ++ types ++ dctors ++ values)+    where+    go :: (ModuleName, Name) -> UsedImports -> UsedImports+    go (q, name) acc = M.alter (Just . maybe [name] (name :)) q acc++  extractByQual+    :: (Eq a)+    => ModuleName+    -> M.Map (Qualified a) [(Qualified a, ModuleName)]+    -> (Qualified a -> Name)+    -> [(ModuleName, Name)]+  extractByQual k m toName = mapMaybe go (M.toList m)+    where+    go (q@(Qualified mnq _), is) | isUnqualified q || isQualifiedWith k q =+      case fst (head is) of+        Qualified (Just mn') name -> Just (mn', toName $ Qualified mnq name)+        _ -> internalError "unqualified name in extractByQual"+    go _ = Nothing++lintImportDecl+  :: forall m+   . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)+  => Env+  -> ModuleName+  -> Maybe ModuleName+  -> [Name]+  -> ImportDeclarationType+  -> m ()+lintImportDecl env mni qualifierName names declType =+  case declType of+    Implicit -> case qualifierName of+      Nothing -> checkImplicit ImplicitImport+      Just q ->+        let usedModuleNames = mapMaybe extractQualName names+        in unless (q `elem` usedModuleNames) unused+    Hiding _ -> checkImplicit HidingImport+    Explicit [] -> unused+    Explicit declrefs -> checkExplicit declrefs++  where++  checkImplicit+    :: (ModuleName -> [DeclarationRef] -> SimpleErrorMessage)+    -> m ()+  checkImplicit warning =+    if null allRefs+    then unused+    else tell $ errorMessage $ warning mni allRefs++  checkExplicit+    :: [DeclarationRef]+    -> m ()+  checkExplicit declrefs = do+    let idents = nub (mapMaybe runDeclRef declrefs)+        dctors = mapMaybe (matchDctor qualifierName) names+        usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names+        diff = idents \\ usedNames+    case (length diff, length idents) of+      (0, _) -> return ()+      (n, m) | n == m -> unused+      _ -> tell $ errorMessage $ UnusedExplicitImport mni diff qualifierName allRefs++    -- If we've not already warned a type is unused, check its data constructors+    forM_ (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do+      let allCtors = dctorsForType mni tn+      when (runProperName tn `elem` usedNames) $ case (c, dctors `intersect` allCtors) of+        (_, []) | c /= Just [] ->+          tell $ errorMessage $ UnusedDctorImport tn+        (Just ctors, dctors') ->+          let ddiff = ctors \\ dctors'+          in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff+        _ -> return ()+    return ()++  unused :: m ()+  unused = tell $ errorMessage $ UnusedImport mni++  allRefs :: [DeclarationRef]+  allRefs = findUsedRefs env mni qualifierName names++  dtys+    :: ModuleName+    -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]   dtys mn = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env -  dctorsForType :: ModuleName -> ProperName -> [ProperName]+  dctorsForType+    :: ModuleName+    -> ProperName 'TypeName+    -> [ProperName 'ConstructorName]   dctorsForType mn tn =     maybe [] getDctors (find matches $ dtys mn)     where       matches ((ty, _),_) = ty == tn       getDctors ((_,ctors),_) = ctors -  typeForDCtor :: ModuleName -> ProperName -> Maybe ProperName+  typeForDCtor+    :: ModuleName+    -> ProperName 'ConstructorName+    -> Maybe (ProperName 'TypeName)   typeForDCtor mn pn =     getTy <$> find matches (dtys mn)     where       matches ((_, ctors), _) = pn `elem` ctors       getTy ((ty, _), _) = ty +findUsedRefs :: Env -> ModuleName -> Maybe ModuleName -> [Name] -> [DeclarationRef]+findUsedRefs env mni qualifierName names =+  let+    classRefs = TypeClassRef <$> mapMaybe (getClassName qualifierName) names+    valueRefs = ValueRef <$> mapMaybe (getIdentName qualifierName) names+    types = mapMaybe (getTypeName qualifierName) names+    dctors = mapMaybe (matchDctor qualifierName) names+    typesWithDctors = reconstructTypeRefs dctors+    typesWithoutDctors = filter (`M.notMember` typesWithDctors) types+    typesRefs+      = map (flip TypeRef (Just [])) typesWithoutDctors+      ++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors)+  in classRefs ++ typesRefs ++ valueRefs -matchName :: (ProperName -> Maybe ProperName) -> Maybe ModuleName -> Name -> Maybe String+  where++  reconstructTypeRefs+    :: [ProperName 'ConstructorName]+    -> M.Map (ProperName 'TypeName) [ProperName 'ConstructorName]+  reconstructTypeRefs = foldr accumDctors M.empty+    where+    accumDctors dctor = M.alter (Just . maybe [dctor] (dctor :)) (findTypeForDctor mni dctor)++  findTypeForDctor+    :: ModuleName+    -> ProperName 'ConstructorName+    -> ProperName 'TypeName+  findTypeForDctor mn dctor =+    case mn `M.lookup` env of+      Just (_, _, exps) ->+        case find (elem dctor . snd . fst) (exportedTypes exps) of+          Just ((ty, _), _) -> ty+          Nothing -> internalError $ "missing type for data constructor " ++ runProperName dctor ++ " in findTypeForDctor"+      Nothing -> internalError $ "missing module " ++ runModuleName mn  ++ " in findTypeForDctor"++matchName+  :: (ProperName 'ConstructorName -> Maybe (ProperName 'TypeName))+  -> Maybe ModuleName+  -> Name+  -> Maybe String matchName _ qual (IdentName (Qualified q x)) | q == qual = Just $ showIdent x-matchName _ qual (IsProperName (Qualified q x)) | q == qual = Just $ runProperName x+matchName _ qual (TyName (Qualified q x)) | q == qual = Just $ runProperName x+matchName _ qual (TyClassName (Qualified q x)) | q == qual = Just $ runProperName x matchName lookupDc qual (DctorName (Qualified q x)) | q == qual = runProperName <$> lookupDc x matchName _ _ _ = Nothing -matchDctor :: Maybe ModuleName -> Name -> Maybe ProperName+extractQualName :: Name -> Maybe ModuleName+extractQualName (IdentName (Qualified q _)) = q+extractQualName (TyName (Qualified q _)) = q+extractQualName (TyClassName (Qualified q _)) = q+extractQualName (DctorName (Qualified q _)) = q++matchDctor :: Maybe ModuleName -> Name -> Maybe (ProperName 'ConstructorName) matchDctor qual (DctorName (Qualified q x)) | q == qual = Just x matchDctor _ _ = Nothing @@ -114,9 +305,12 @@ runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref runDeclRef (ValueRef ident) = Just $ showIdent ident runDeclRef (TypeRef pn _) = Just $ runProperName pn+runDeclRef (TypeClassRef pn) = Just $ runProperName pn runDeclRef _ = Nothing -getTypeRef :: DeclarationRef -> Maybe (ProperName, Maybe [ProperName])+getTypeRef+  :: DeclarationRef+  -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) getTypeRef (PositionedDeclarationRef _ _ ref) = getTypeRef ref getTypeRef (TypeRef pn x) = Just (pn, x) getTypeRef _ = Nothing
src/Language/PureScript/Make.hs view
@@ -1,18 +1,3 @@------------------------------------------------------------------------------------ Module      :  Make--- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess--- License     :  MIT (http://opensource.org/licenses/MIT)------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |-----------------------------------------------------------------------------------{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TupleSections #-}@@ -63,6 +48,7 @@ import Data.Version (showVersion) import Data.Aeson (encode, decode) import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString.UTF8 as BU8 import qualified Data.Set as S import qualified Data.Map as M @@ -70,6 +56,7 @@        (doesFileExist, getModificationTime, createDirectoryIfMissing) import System.FilePath ((</>), takeDirectory) import System.IO.Error (tryIOError)+import System.IO.UTF8 (readUTF8File, writeUTF8File)  import Language.PureScript.Crash import Language.PureScript.AST@@ -123,7 +110,7 @@   -- |   -- Read the externs file for a module as a string and also return the actual   -- path for the file.-  , readExterns :: ModuleName -> m (FilePath, B.ByteString)+  , readExterns :: ModuleName -> m (FilePath, Externs)   -- |   -- Run the code generator for the module and write any required output files.   --@@ -137,7 +124,7 @@ -- | -- Generated code for an externs file. ---type Externs = B.ByteString+type Externs = String  -- | -- Determines when to rebuild a module@@ -223,15 +210,16 @@                 progress $ CompilingModule moduleName                 let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs                 lint m-                ([desugared], nextVar) <- runSupplyT 0 $ desugar externs [m]-                (checked@(Module ss coms _ elaborated exps), env') <- runCheck' env $ typeCheckModule desugared+                ((checked@(Module ss coms _ elaborated exps), env'), nextVar) <- runSupplyT 0 $ do+                  [desugared] <- desugar externs [m]+                  runCheck' env $ typeCheckModule desugared                 checkExhaustiveModule env' checked                 regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated                 let mod' = Module ss coms moduleName regrouped exps                     corefn = CF.moduleToCoreFn env' mod'                     [renamed] = renameInModules [corefn]                     exts = moduleToExternsFile mod' env'-                evalSupplyT nextVar $ codegen renamed env' $ encode exts+                evalSupplyT nextVar . codegen renamed env' . BU8.toString . B.toStrict . encode $ exts                 return exts               markComplete (Just (warnings, exts)) Nothing @@ -258,24 +246,12 @@   shouldExist (Just t) = t   shouldExist _ = internalError "make: dependency should already have been built." -  decodeExterns :: B.ByteString -> Maybe ExternsFile+  decodeExterns :: Externs -> Maybe ExternsFile   decodeExterns bs = do-    externs <- decode bs+    externs <- decode (fromString bs)     guard $ efVersion externs == showVersion Paths.version     return externs --- |--- Add an import declaration for a module if it does not already explicitly import it.----addDefaultImport :: ModuleName -> Module -> Module-addDefaultImport toImport m@(Module ss coms mn decls exps)  =-  if isExistingImport `any` decls || mn == toImport then m-  else Module ss coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps-  where-  isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True-  isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d-  isExistingImport _ = False- importPrim :: Module -> Module importPrim = addDefaultImport (ModuleName [ProperName C.prim]) @@ -335,7 +311,7 @@         externsFile = outputDir </> filePath </> "externs.json"     min <$> getTimestamp jsFile <*> getTimestamp externsFile -  readExterns :: ModuleName -> Make (FilePath, B.ByteString)+  readExterns :: ModuleName -> Make (FilePath, Externs)   readExterns mn = do     let path = outputDir </> runModuleName mn </> "externs.json"     (path, ) <$> readTextFile path@@ -371,13 +347,13 @@     exists <- doesFileExist path     traverse (const $ getModificationTime path) $ guard exists -  readTextFile :: FilePath -> Make B.ByteString-  readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ B.readFile path+  readTextFile :: FilePath -> Make String+  readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path -  writeTextFile :: FilePath -> B.ByteString -> Make ()+  writeTextFile :: FilePath -> String -> Make ()   writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do     mkdirp path-    B.writeFile path text+    writeUTF8File path text     where     mkdirp :: FilePath -> IO ()     mkdirp = createDirectoryIfMissing True . takeDirectory
src/Language/PureScript/ModuleDependencies.hs view
@@ -23,7 +23,7 @@  import Data.Graph import Data.List (nub)-import Data.Maybe (fromMaybe, mapMaybe)+import Data.Maybe (fromMaybe)  import Language.PureScript.Crash import Language.PureScript.AST@@ -54,21 +54,24 @@ -- Calculate a list of used modules based on explicit imports and qualified names -- usedModules :: Declaration -> [ModuleName]-usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const []) in nub . f+usedModules d =+  let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const [])+      (g, _, _, _, _) = accumTypes (everythingOnTypes (++) forTypes)+  in nub (f d ++ g d)   where   forDecls :: Declaration -> [ModuleName]-  forDecls (ImportDeclaration mn _ _) = [mn]+  forDecls (ImportDeclaration mn _ _ _) = [mn]+  forDecls (FixityDeclaration _ _ (Just (Qualified (Just mn) _))) = [mn]+  forDecls (TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) = [mn]   forDecls _ = []    forValues :: Expr -> [ModuleName]   forValues (Var (Qualified (Just mn) _)) = [mn]   forValues (Constructor (Qualified (Just mn) _)) = [mn]-  forValues (TypedValue _ _ ty) = forTypes ty   forValues _ = []    forTypes :: Type -> [ModuleName]   forTypes (TypeConstructor (Qualified (Just mn) _)) = [mn]-  forTypes (ConstrainedType cs _) = mapMaybe (\(Qualified mn _, _) -> mn) cs   forTypes _ = []  -- |
src/Language/PureScript/Names.hs view
@@ -1,31 +1,19 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Names--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- Data types for names-----------------------------------------------------------------------------------{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE KindSignatures #-} +-- |+-- Data types for names+-- module Language.PureScript.Names where +import Control.Monad (liftM)+import Control.Monad.Supply.Class+ import Data.List-import Data.Data-import Data.List.Split (splitOn)+import Data.Aeson import Data.Aeson.TH-import qualified Data.Aeson as A-import qualified Data.Text as T  -- | -- Names for value identifiers@@ -38,25 +26,59 @@   -- |   -- A symbolic name for an infix operator   ---  | Op String deriving (Show, Read, Eq, Ord, Data, Typeable)+  | Op String+  -- |+  -- A generated name for an identifier+  --+  | GenIdent (Maybe String) Integer+  deriving (Show, Read, Eq, Ord)  runIdent :: Ident -> String runIdent (Ident i) = i runIdent (Op op) = op+runIdent (GenIdent Nothing n) = "$" ++ show n+runIdent (GenIdent (Just name) n) = "$" ++ name ++ show n  showIdent :: Ident -> String-showIdent (Ident i) = i showIdent (Op op) = '(' : op ++ ")"+showIdent i = runIdent i +freshIdent :: (MonadSupply m) => String -> m Ident+freshIdent name = liftM (GenIdent (Just name)) fresh++freshIdent' :: (MonadSupply m) => m Ident+freshIdent' = liftM (GenIdent Nothing) fresh+ -- | -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors. ---newtype ProperName = ProperName { runProperName :: String } deriving (Show, Read, Eq, Ord, Data, Typeable)+newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: String }+  deriving (Show, Read, Eq, Ord) +instance ToJSON (ProperName a) where+  toJSON = toJSON . runProperName++instance FromJSON (ProperName a) where+  parseJSON = fmap ProperName . parseJSON+ -- |+-- The closed set of proper name types.+--+data ProperNameType = TypeName | ConstructorName | ClassName | Namespace++-- |+-- Coerces a ProperName from one ProperNameType to another. This should be used+-- with care, and is primarily used to convert ClassNames into TypeNames after+-- classes have been desugared.+--+coerceProperName :: ProperName a -> ProperName b+coerceProperName = ProperName . runProperName++-- | -- Module names ---newtype ModuleName = ModuleName [ProperName] deriving (Show, Read, Eq, Ord, Data, Typeable)+newtype ModuleName = ModuleName [ProperName 'Namespace]+  deriving (Show, Read, Eq, Ord)  runModuleName :: ModuleName -> String runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)@@ -72,25 +94,13 @@ -- | -- A qualified name, i.e. a name with an optional module name ---data Qualified a = Qualified (Maybe ModuleName) a deriving (Show, Read, Eq, Ord, Data, Typeable, Functor)+data Qualified a = Qualified (Maybe ModuleName) a+  deriving (Show, Read, Eq, Ord, Functor)  showQualified :: (a -> String) -> Qualified a -> String showQualified f (Qualified Nothing a) = f a showQualified f (Qualified (Just name) a) = runModuleName name ++ "." ++ f a -instance (a ~ ProperName) => A.ToJSON (Qualified a) where-  toJSON = A.toJSON . showQualified runProperName--instance (a ~ ProperName) => A.FromJSON (Qualified a) where-  parseJSON =-    A.withText "Qualified ProperName" $ \str ->-      return $ case reverse (splitOn "." (T.unpack str)) of-        [name]      -> Qualified Nothing (ProperName name)-        (name:rest) -> Qualified (Just (reconstructModuleName rest)) (ProperName name)-        _           -> Qualified Nothing (ProperName "")-    where-    reconstructModuleName = moduleNameFromString . intercalate "." . reverse- -- | -- Provide a default module name, if a name is unqualified --@@ -111,10 +121,23 @@ -- | -- Checks whether a qualified value is actually qualified with a module reference --+isQualified :: Qualified a -> Bool+isQualified (Qualified Nothing _) = False+isQualified _ = True++-- |+-- Checks whether a qualified value is not actually qualified with a module reference+-- isUnqualified :: Qualified a -> Bool-isUnqualified (Qualified Nothing _) = True-isUnqualified _ = False+isUnqualified = not . isQualified +-- |+-- Checks whether a qualified value is qualified with a particular module+--+isQualifiedWith :: ModuleName -> Qualified a -> Bool+isQualifiedWith mn (Qualified (Just mn') _) = mn == mn'+isQualifiedWith _ _ = False++$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Qualified) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident)-$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ProperName) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ModuleName)
src/Language/PureScript/Parser/Common.hs view
@@ -1,20 +1,8 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Parser.Common--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :---+{-# LANGUAGE FlexibleContexts #-}+ -- | -- Constants, and utility functions to be used when parsing ----------------------------------------------------------------------------------{-# LANGUAGE FlexibleContexts #-}- module Language.PureScript.Parser.Common where  import Control.Applicative@@ -27,12 +15,7 @@  import qualified Text.Parsec as P -featureWasRemoved :: String -> TokenParser a-featureWasRemoved err = do-  pos <- P.getPosition-  error $ "It looks like you are trying to use a feature from a previous version of the compiler:\n" ++ err ++ "\nat " ++ show pos--properName :: TokenParser ProperName+properName :: TokenParser (ProperName a) properName = ProperName <$> uname  -- |
src/Language/PureScript/Parser/Declarations.hs view
@@ -1,22 +1,10 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Parser.Declarations--- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess--- License     :  MIT (http://opensource.org/licenses/MIT)------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- Parsers for module definitions and declarations---------------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +-- |+-- Parsers for module definitions and declarations+-- module Language.PureScript.Parser.Declarations (     parseDeclaration,     parseModule,@@ -45,6 +33,7 @@ import Language.PureScript.Errors import Language.PureScript.Kinds import Language.PureScript.Names+import Language.PureScript.Types import Language.PureScript.Parser.Common import Language.PureScript.Parser.Kinds import Language.PureScript.Parser.Lexer@@ -87,7 +76,7 @@  parseTypeSynonymDeclaration :: TokenParser Declaration parseTypeSynonymDeclaration =-  TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName)+  TypeSynonymDeclaration <$> (reserved "type" *> indented *> properName)                          <*> many (indented *> kindedIdent)                          <*> (indented *> equals *> noWildcards parsePolyType) @@ -113,21 +102,18 @@     return $ maybe value (`Let` value) whereClause  parseExternDeclaration :: TokenParser Declaration-parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *>-   (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)+parseExternDeclaration = reserved "foreign" *> indented *> reserved "import" *> indented *>+   (ExternDataDeclaration <$> (reserved "data" *> indented *> properName)                           <*> (indented *> doubleColon *> parseKind)    <|> (do ident <- parseIdent-           -- TODO: add a wiki page link with migration info-           -- TODO: remove this deprecation warning in 0.8-           _ <- P.optional $ stringLiteral *> featureWasRemoved "Inline foreign string literals are no longer supported."            ty <- indented *> doubleColon *> noWildcards parsePolyType            return $ ExternDeclaration ident ty))  parseAssociativity :: TokenParser Associativity parseAssociativity =-  (P.try (reserved "infixl") >> return Infixl) <|>-  (P.try (reserved "infixr") >> return Infixr) <|>-  (P.try (reserved "infix") >>  return Infix)+  (reserved "infixl" *> return Infixl) <|>+  (reserved "infixr" *> return Infixr) <|>+  (reserved "infix"  *> return Infix)  parseFixity :: TokenParser Fixity parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural)@@ -136,15 +122,16 @@ parseFixityDeclaration = do   fixity <- parseFixity   indented+  alias <- P.optionMaybe $ parseQualified (Ident <$> identifier) <* reserved "as"   name <- symbol-  return $ FixityDeclaration fixity name+  return $ FixityDeclaration fixity name alias  parseImportDeclaration :: TokenParser Declaration parseImportDeclaration = do-  (mn, declType, asQ) <- parseImportDeclaration'-  return $ ImportDeclaration mn declType asQ+  (mn, declType, asQ, isOldSyntax) <- parseImportDeclaration'+  return $ ImportDeclaration mn declType asQ isOldSyntax -parseImportDeclaration' :: TokenParser (ModuleName, ImportDeclarationType, Maybe ModuleName)+parseImportDeclaration' :: TokenParser (ModuleName, ImportDeclarationType, Maybe ModuleName, Bool) parseImportDeclaration' = do   reserved "import"   indented@@ -152,16 +139,9 @@   where   stdImport = do     moduleName' <- moduleName-    suffixHiding moduleName' <|> suffixQualifyingList moduleName'-    where-    suffixHiding mn = do-      reserved "hiding"-      declType <- qualifyingList Hiding-      return (mn, declType, Nothing)-    suffixQualifyingList mn = do-      declType <- qualifyingList Explicit-      qName <- P.optionMaybe qualifiedName-      return (mn, declType, qName)+    declType <- reserved "hiding" *> qualifyingList Hiding <|> qualifyingList Explicit+    qName <- P.optionMaybe qualifiedName+    return (moduleName', declType, qName, False)   qualifiedName = reserved "as" *> moduleName   qualImport = do     reserved "qualified"@@ -169,33 +149,30 @@     moduleName' <- moduleName     declType <- qualifyingList Explicit     qName <- qualifiedName-    return (moduleName', declType, Just qName)+    return (moduleName', declType, Just qName, True)   qualifyingList expectedType = do-    idents <- P.optionMaybe $ indented *> parens (commaSep parseDeclarationRef)-    return $ fromMaybe Implicit (expectedType <$> idents)-+    declType <- P.optionMaybe (expectedType <$> (indented *> parens (commaSep parseDeclarationRef)))+    return $ fromMaybe Implicit declType  parseDeclarationRef :: TokenParser DeclarationRef parseDeclarationRef =-  parseModuleRef <|>   withSourceSpan PositionedDeclarationRef-  (ValueRef <$> parseIdent-    <|> do name <- properName-           dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName)-           return $ maybe (TypeClassRef name) (TypeRef name) dctors-  )+    $ (ValueRef <$> parseIdent)+    <|> parseProperRef+    <|> (TypeClassRef <$> (reserved "class" *> properName))+    <|> (ModuleRef <$> (indented *> reserved "module" *> moduleName))   where-  parseModuleRef :: TokenParser DeclarationRef-  parseModuleRef = do-    name <- indented *> reserved "module" *> moduleName-    return $ ModuleRef name+  parseProperRef = do+    name <- properName+    dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName)+    return $ maybe (ProperRef (runProperName name)) (TypeRef name) dctors  parseTypeClassDeclaration :: TokenParser Declaration parseTypeClassDeclaration = do   reserved "class"-  implies <- P.option [] $ do+  implies <- P.option [] . P.try $ do     indented-    implies <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))+    implies <- (return <$> parseConstraint) <|> parens (commaSep1 parseConstraint)     lfatArrow     return implies   className <- indented *> properName@@ -204,13 +181,17 @@     indented *> reserved "where"     indented *> mark (P.many (same *> positioned parseTypeDeclaration))   return $ TypeClassDeclaration className idents implies members+  where +parseConstraint :: TokenParser Constraint+parseConstraint = (,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)+ parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration) parseInstanceDeclaration = do   reserved "instance"   name <- parseIdent <* indented <* doubleColon-  deps <- P.optionMaybe $ do-    deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))+  deps <- P.optionMaybe $ P.try $ do+    deps <- (return <$> parseConstraint) <|> parens (commaSep1 parseConstraint)     indented     rfatArrow     return deps@@ -341,12 +322,13 @@     return (name, b)   <|> (,) <$> (C.indented *> stringLiteral) <*> rest   where-  rest = C.indented *> colon *>  C.indented *>  val-  val = (Just <$> parseValue) <|> (underscore *> pure Nothing)+  rest = C.indented *> colon *> C.indented *> val+  val = P.try (Just <$> parseValue) <|> (underscore *> pure Nothing)  parseAbs :: TokenParser Expr parseAbs = do   symbol' "\\"+  -- TODO: remove this 'try' after operator aliases are finished (0.9)   args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))   C.indented *> rarrow   value <- parseValue@@ -362,11 +344,11 @@ parseConstructor = Constructor <$> C.parseQualified C.properName  parseCase :: TokenParser Expr-parseCase = Case <$> P.between (P.try (reserved "case")) (C.indented *> reserved "of") (return <$> parseValue)+parseCase = Case <$> P.between (reserved "case") (C.indented *> reserved "of") (commaSep1 parseValue)                  <*> (C.indented *> C.mark (P.many1 (C.same *> C.mark parseCaseAlternative)))  parseCaseAlternative :: TokenParser CaseAlternative-parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)+parseCaseAlternative = CaseAlternative <$> (commaSep1 parseBinder)                                        <*> (Left <$> (C.indented *>                                                         P.many1 ((,) <$> parseGuard                                                                      <*> (indented *> rarrow *> parseValue)@@ -391,23 +373,25 @@  parseValueAtom :: TokenParser Expr parseValueAtom = P.choice-            [ P.try parseNumericLiteral-            , P.try parseCharLiteral-            , P.try parseStringLiteral-            , P.try parseBooleanLiteral-            , parseArrayLiteral-            , P.try parseObjectLiteral-            , P.try parseObjectGetter-            , parseAbs-            , P.try parseConstructor-            , P.try parseVar-            , parseCase-            , parseIfThenElse-            , parseDo-            , parseLet-            , P.try $ Parens <$> parens parseValue-            , parseOperatorSection-            , P.try parseObjectUpdaterWildcard ]+                 [ parseNumericLiteral+                 , parseCharLiteral+                 , parseStringLiteral+                 , parseBooleanLiteral+                 , parseArrayLiteral+                 , P.try parseObjectLiteral+                 , P.try parseObjectGetter+                 , parseAbs+                 , P.try parseConstructor+                 , P.try parseVar+                 , parseCase+                 , parseIfThenElse+                 , parseDo+                 , parseLet+                 , P.try $ Parens <$> parens parseValue+                 , parseOperatorSection+                 -- TODO: combine this with parseObjectGetter+                 , parseObjectUpdaterWildcard+                 ]  -- | -- Parse an expression in backticks or an operator@@ -443,13 +427,14 @@ parseDoNotationLet = DoNotationLet <$> (reserved "let" *> C.indented *> C.mark (P.many1 (C.same *> parseLocalDeclaration)))  parseDoNotationBind :: TokenParser DoNotationElement-parseDoNotationBind = DoNotationBind <$> parseBinder <*> (C.indented *> larrow *> parseValue)+parseDoNotationBind = DoNotationBind <$> P.try (parseBinder <* C.indented <* larrow) <*> parseValue  parseDoNotationElement :: TokenParser DoNotationElement parseDoNotationElement = P.choice-            [ P.try parseDoNotationBind+            [ parseDoNotationBind             , parseDoNotationLet-            , P.try (DoNotationValue <$> parseValue) ]+            , DoNotationValue <$> parseValue+            ]  parseObjectGetter :: TokenParser Expr parseObjectGetter = ObjectGetter <$> (underscore *> C.indented *> dot *> C.indented *> (lname <|> stringLiteral))@@ -459,7 +444,8 @@ indexersAndAccessors = C.buildPostfixParser postfixTable parseValueAtom   where   postfixTable = [ parseAccessor-                 , P.try . parseUpdaterBody . Just ]+                 , P.try . parseUpdaterBody . Just+                 ]  -- | -- Parse a value@@ -471,9 +457,9 @@     $ indexersAndAccessors) P.<?> "expression"   where   postfixTable = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v-                 , \v -> flip (TypedValue True) <$> (P.try (C.indented *> doubleColon) *> parsePolyType) <*> pure v+                 , \v -> flip (TypedValue True) <$> (C.indented *> doubleColon *> parsePolyType) <*> pure v                  ]-  operators = [ [ P.Prefix (P.try (C.indented *> symbol' "-") >> return UnaryMinus)+  operators = [ [ P.Prefix (C.indented *> symbol' "-" *> return UnaryMinus)                 ]               , [ P.Infix (P.try (C.indented *> parseInfixExpr P.<?> "infix expression") >>= \ident ->                     return (BinaryNoParens ident)) P.AssocRight@@ -503,9 +489,6 @@          <|> (symbol' "+" >> return id)          <|> return id -parseVarBinder :: TokenParser Binder-parseVarBinder = VarBinder <$> C.parseIdent- parseNullaryConstructorBinder :: TokenParser Binder parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> pure [] @@ -518,9 +501,13 @@ parseArrayBinder :: TokenParser Binder parseArrayBinder = squares $ ArrayBinder <$> commaSep (C.indented *> parseBinder) -parseNamedBinder :: TokenParser Binder-parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* at)-                               <*> (C.indented *> parseBinder)+parseVarOrNamedBinder :: TokenParser Binder+parseVarOrNamedBinder = do+  -- TODO: once operator aliases are finalized in 0.9, this 'try' won't be needed+  -- any more since identifiers in binders won't be 'Op's.+  name <- P.try C.parseIdent+  let parseNamedBinder = NamedBinder name <$> (at *> C.indented *> parseBinder)+  parseNamedBinder <|> return (VarBinder name)  parseNullBinder :: TokenParser Binder parseNullBinder = underscore *> return NullBinder@@ -538,43 +525,41 @@ -- Parse a binder -- parseBinder :: TokenParser Binder-parseBinder = withSourceSpan PositionedBinder (P.buildExpressionParser operators (buildPostfixParser postfixTable parseBinderAtom))+parseBinder = withSourceSpan PositionedBinder (buildPostfixParser postfixTable parseBinderAtom)   where-  -- TODO: remove this deprecation warning in 0.8-  operators = [ [ P.Infix (P.try $ C.indented *> colon *> featureWasRemoved "Cons binders are no longer supported. Consider using purescript-lists or purescript-sequences instead.") P.AssocRight ] ]   -- TODO: parsePolyType when adding support for polymorphic types-  postfixTable = [ \b -> flip TypedBinder b <$> (P.try (indented *> doubleColon) *> parseType)+  postfixTable = [ \b -> flip TypedBinder b <$> (indented *> doubleColon *> parseType)                  ]   parseBinderAtom :: TokenParser Binder-  parseBinderAtom = P.choice (map P.try+  parseBinderAtom = P.choice                     [ parseNullBinder                     , parseCharBinder                     , parseStringBinder                     , parseBooleanBinder                     , parseNumberBinder-                    , parseNamedBinder-                    , parseVarBinder+                    , parseVarOrNamedBinder                     , parseConstructorBinder                     , parseObjectBinder                     , parseArrayBinder-                    , parens parseBinder ]) P.<?> "binder"+                    , parens parseBinder+                    ] P.<?> "binder"  -- | -- Parse a binder as it would appear in a top level declaration -- parseBinderNoParens :: TokenParser Binder-parseBinderNoParens = P.choice (map P.try-                  [ parseNullBinder-                  , parseCharBinder-                  , parseStringBinder-                  , parseBooleanBinder-                  , parseNumberBinder-                  , parseNamedBinder-                  , parseVarBinder-                  , parseNullaryConstructorBinder-                  , parseObjectBinder-                  , parseArrayBinder-                  , parens parseBinder ]) P.<?> "binder"+parseBinderNoParens = P.choice+                      [ parseNullBinder+                      , parseCharBinder+                      , parseStringBinder+                      , parseBooleanBinder+                      , parseNumberBinder+                      , parseVarOrNamedBinder+                      , parseNullaryConstructorBinder+                      , parseObjectBinder+                      , parseArrayBinder+                      , parens parseBinder+                      ] P.<?> "binder"  -- | -- Parse a guard
src/Language/PureScript/Parser/Kinds.hs view
@@ -33,10 +33,11 @@ parseBang = const Bang <$> symbol' "!"  parseTypeAtom :: TokenParser Kind-parseTypeAtom = indented *> P.choice (map P.try+parseTypeAtom = indented *> P.choice             [ parseStar             , parseBang-            , parens parseKind ])+            , parens parseKind+            ] -- | -- Parse a kind --@@ -44,4 +45,4 @@ parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind"   where   operators = [ [ P.Prefix (symbol' "#" >> return Row) ]-              , [ P.Infix (P.try rarrow >> return FunKind) P.AssocRight ] ]+              , [ P.Infix (rarrow >> return FunKind) P.AssocRight ] ]
src/Language/PureScript/Parser/Lexer.hs view
@@ -67,13 +67,13 @@   , natural   , reservedPsNames   , reservedTypeNames-  , opChars+  , isSymbolChar   )   where  import Prelude hiding (lex) -import Data.Char (isSpace)+import Data.Char (isSpace, isAscii, isSymbol)  import Control.Monad (void, guard) import Data.Functor.Identity@@ -185,10 +185,15 @@ parseToken :: P.Parsec String u Token parseToken = P.choice   [ P.try $ P.string "<-" *> P.notFollowedBy symbolChar *> pure LArrow+  , P.try $ P.string "←"  *> P.notFollowedBy symbolChar *> pure LArrow   , P.try $ P.string "<=" *> P.notFollowedBy symbolChar *> pure LFatArrow+  , P.try $ P.string "⇐"  *> P.notFollowedBy symbolChar *> pure LFatArrow   , P.try $ P.string "->" *> P.notFollowedBy symbolChar *> pure RArrow+  , P.try $ P.string "→"  *> P.notFollowedBy symbolChar *> pure RArrow   , P.try $ P.string "=>" *> P.notFollowedBy symbolChar *> pure RFatArrow+  , P.try $ P.string "⇒"  *> P.notFollowedBy symbolChar *> pure RFatArrow   , P.try $ P.string "::" *> P.notFollowedBy symbolChar *> pure DoubleColon+  , P.try $ P.string "∷"  *> P.notFollowedBy symbolChar *> pure DoubleColon   , P.try $ P.char '('    *> pure LParen   , P.try $ P.char ')'    *> pure RParen   , P.try $ P.char '{'    *> pure LBrace@@ -233,7 +238,7 @@   uidentLetter = P.alphaNum <|> P.char '_'    symbolChar :: P.Parsec String u Char-  symbolChar = P.oneOf opChars+  symbolChar = P.satisfy isSymbolChar    parseCharLiteral :: P.Parsec String u Char   parseCharLiteral = PT.charLiteral tokenParser@@ -411,6 +416,7 @@ reserved s = token go P.<?> show s   where   go (LName s') | s == s' = Just ()+  go (Symbol s') | s == s' = Just ()   go _ = Nothing  uname :: TokenParser String@@ -516,5 +522,5 @@ -- | -- The characters allowed for use in operators ---opChars :: [Char]-opChars = ":!#$%&*+./<=>?@\\^|-~"+isSymbolChar :: Char -> Bool+isSymbolChar c = (c `elem` ":!#$%&*+./<=>?@\\^|-~") || (not (isAscii c) && isSymbol c)
src/Language/PureScript/Parser/Types.hs view
@@ -1,18 +1,3 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Parser.Types--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- Parsers for types---------------------------------------------------------------------------------- module Language.PureScript.Parser.Types (     parseType,     parsePolyType,@@ -32,19 +17,8 @@ import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P --- TODO: remove these deprecation warnings in 0.8-parseArray :: TokenParser Type-parseArray = do-  _ <- squares $ return tyArray-  featureWasRemoved "Array notation is no longer supported. Use Array instead of []."--parseArrayOf :: TokenParser Type-parseArrayOf = do-  _ <- squares $ TypeApp tyArray <$> parseType-  featureWasRemoved "Array notation is no longer supported. Use Array _ instead of [_]."- parseFunction :: TokenParser Type-parseFunction = parens $ rarrow >> return tyFunction+parseFunction = parens rarrow >> return tyFunction  parseObject :: TokenParser Type parseObject = braces $ TypeApp tyObject <$> parseRow@@ -62,45 +36,48 @@ parseTypeConstructor = TypeConstructor <$> parseQualified properName  parseForAll :: TokenParser Type-parseForAll = mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot)+parseForAll = mkForAll <$> ((reserved "forall" <|> reserved "∀") *> P.many1 (indented *> identifier) <* indented <* dot)                        <*> parseType  -- | -- Parse a type as it appears in e.g. a data constructor -- parseTypeAtom :: TokenParser Type-parseTypeAtom = indented *> P.choice (map P.try-            [ parseArray-            , parseArrayOf-            , parseFunction+parseTypeAtom = indented *> P.choice+            [ P.try parseConstrainedType+            , P.try parseFunction             , parseObject             , parseTypeWildcard+            , parseForAll             , parseTypeVariable             , parseTypeConstructor-            , parseForAll-            , parens parseRow-            , parseConstrainedType+            -- This try is needed due to some unfortunate ambiguities between rows and kinded types+            , P.try (parens parseRow)             , parens parsePolyType-            ])+            ]  parseConstrainedType :: TokenParser Type parseConstrainedType = do-  constraints <- parens . commaSep1 $ do-    className <- parseQualified properName-    indented-    ty <- P.many parseTypeAtom-    return (className, ty)+  constraints <- P.try (return <$> parseConstraint) <|> parens (commaSep1 parseConstraint)   _ <- rfatArrow   indented   ty <- parseType   return $ ConstrainedType constraints ty+  where+  parseConstraint = do+    className <- parseQualified properName+    indented+    ty <- P.many parseTypeAtom+    return (className, ty) + parseAnyType :: TokenParser Type parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P.<?> "type"   where   operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]-              , [ P.Infix (rarrow >> return function) P.AssocRight ] ]-  postfixTable = [ \t -> KindedType t <$> (P.try (indented *> doubleColon) *> parseKind)+              , [ P.Infix (rarrow >> return function) P.AssocRight ]+              ]+  postfixTable = [ \t -> KindedType t <$> (indented *> doubleColon *> parseKind)                  ]  -- |
src/Language/PureScript/Pretty/Common.hs view
@@ -18,7 +18,7 @@ import Control.Monad.State import Data.List (intercalate) -import Language.PureScript.Parser.Lexer (reservedPsNames, opChars)+import Language.PureScript.Parser.Lexer (reservedPsNames, isSymbolChar)  import Text.PrettyPrint.Boxes @@ -68,7 +68,7 @@ -- prettyPrintObjectKey :: String -> String prettyPrintObjectKey s | s `elem` reservedPsNames = show s-                       | any (`elem` opChars) s = show s+                       | any isSymbolChar s = show s                        | otherwise = s  -- | Place a box before another, vertically when the first box takes up multiple lines.
src/Language/PureScript/Pretty/Types.hs view
@@ -1,26 +1,14 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Pretty.Types--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :--- -- | -- Pretty printer for Types ----------------------------------------------------------------------------------module Language.PureScript.Pretty.Types (-    typeAsBox,-    prettyPrintType,-    typeAtomAsBox,-    prettyPrintTypeAtom,-    prettyPrintRowWith,-    prettyPrintRow-) where+module Language.PureScript.Pretty.Types+  ( typeAsBox+  , prettyPrintType+  , typeAtomAsBox+  , prettyPrintTypeAtom+  , prettyPrintRowWith+  , prettyPrintRow+  ) where  import Data.Maybe (fromMaybe) @@ -45,16 +33,16 @@   match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row   match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor   match (TUnknown u) = Just $ text $ '_' : show u-  match (Skolem name s _) = Just $ text $ name ++ show s+  match (Skolem name s _ _) = Just $ text $ name ++ show s   match REmpty = Just $ text "()"   match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row   match _ = Nothing -constraintsAsBox :: [(Qualified ProperName, [Type])] -> Box -> Box+constraintsAsBox :: [Constraint] -> Box -> Box constraintsAsBox [(pn, tys)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> ty constraintsAsBox xs ty = vcat left (zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> ty) -constraintAsBox :: Qualified ProperName -> [Type] -> Box+constraintAsBox :: Qualified (ProperName a) -> [Type] -> Box constraintAsBox pn tys = hsep 1 left (text (runProperName (disqualify pn)) : map typeAtomAsBox tys)  -- |@@ -79,7 +67,7 @@    toList :: [(String, Type)] -> Type -> ([(String, Type)], Type)   toList tys (RCons name ty row) = toList ((name, ty):tys) row-  toList tys r = (tys, r)+  toList tys r = (reverse tys, r)  prettyPrintRow :: Type -> String prettyPrintRow = render . prettyPrintRowWith '(' ')'@@ -121,20 +109,26 @@   match _ = Nothing  matchTypeAtom :: Pattern () Type Box-matchTypeAtom = typeLiterals <+> fmap ((`before` text ")") . (text "(" <>)) matchType+matchTypeAtom = typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) matchType  matchType :: Pattern () Type Box matchType = buildPrettyPrinter operators matchTypeAtom   where   operators :: OperatorTable () Type Box   operators =-    OperatorTable [ [ AssocL typeApp $ \f x -> f `beforeWithSpace` x ]-                  , [ AssocR appliedFunction $ \arg ret -> (arg <> text " ") `before` (text "-> " <> ret)-                    ]+    OperatorTable [ [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ]+                  , [ AssocR appliedFunction $ \arg ret -> keepSingleLinesOr id arg (text "-> " <> ret) ]                   , [ Wrap constrained $ \deps ty -> constraintsAsBox deps ty ]-                  , [ Wrap forall_ $ \idents ty -> text ("forall " ++ unwords idents ++ ". ") <> ty ]-                  , [ Wrap kinded $ \k ty -> ty `before` text (" :: " ++ prettyPrintKind k) ]+                  , [ Wrap forall_ $ \idents ty -> keepSingleLinesOr (moveRight 2) (text ("forall " ++ unwords idents ++ ".")) ty ]+                  , [ Wrap kinded $ \k ty -> keepSingleLinesOr (moveRight 2) ty (text (":: " ++ prettyPrintKind k)) ]                   ]++  -- If both boxes span a single line, keep them on the same line, or else+  -- use the specified function to modify the second box, then combine vertically.+  keepSingleLinesOr :: (Box -> Box) -> Box -> Box -> Box+  keepSingleLinesOr f b1 b2+    | rows b1 > 1 || rows b2 > 1 = vcat left [ b1, f b2 ]+    | otherwise = hcat top [ b1, text " ", b2]  forall_ :: Pattern () Type ([String], Type) forall_ = mkPattern match
src/Language/PureScript/Pretty/Values.hs view
@@ -160,6 +160,7 @@   ++ " ]" prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder+prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder prettyPrintBinderAtom b = parens (prettyPrintBinder b)  -- |
src/Language/PureScript/Publish.hs view
@@ -146,11 +146,20 @@ getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module]) getModulesAndBookmarks = do   (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles-  liftIO (D.parseAndDesugar inputFiles depsFiles renderModules)-    >>= either (userError . ParseAndDesugarError) return+  (modules', bookmarks, env) <- parseAndDesugar inputFiles depsFiles++  case runExcept (D.convertModulesInPackage env modules') of+    Right modules -> return (bookmarks, modules)+    Left err -> userError (CompileError err)+   where-  renderModules bookmarks modules =-    return (bookmarks, map D.convertModule modules)+  parseAndDesugar inputFiles depsFiles = do+    r <- liftIO . runExceptT $ D.parseAndDesugar inputFiles depsFiles+    case r of+      Right r' ->+        return r'+      Left err ->+        userError (CompileError err)  data TreeStatus = Clean | Dirty deriving (Show, Read, Eq, Ord, Enum) @@ -196,8 +205,7 @@         maybe (Left NotOnGithub) Right (extractGithub repositoryUrl)  extractGithub :: String -> Maybe (D.GithubUser, D.GithubRepo)-extractGithub =-  stripPrefix "git://github.com/"+extractGithub = stripGitHubPrefixes    >>> fmap (splitOn "/")    >=> takeTwo    >>> fmap (D.GithubUser *** (D.GithubRepo . dropDotGit))@@ -206,6 +214,15 @@   takeTwo :: [a] -> Maybe (a, a)   takeTwo [x, y] = Just (x, y)   takeTwo _ = Nothing++  stripGitHubPrefixes :: String -> Maybe String+  stripGitHubPrefixes = stripPrefixes [ "git://github.com/"+                                      , "https://github.com/"+                                      , "git@github.com:"+                                      ]++  stripPrefixes :: [String] -> String -> Maybe String+  stripPrefixes prefixes str = msum $ (`stripPrefix` str) <$> prefixes    dropDotGit :: String -> String   dropDotGit str
src/Language/PureScript/Publish/ErrorsWarnings.hs view
@@ -33,7 +33,6 @@ import qualified Web.Bower.PackageMeta as Bower  import qualified Language.PureScript as P-import qualified Language.PureScript.Docs as D  import Language.PureScript.Publish.BoxesHelpers @@ -61,7 +60,7 @@   | AmbiguousVersions [Version] -- Invariant: should contain at least two elements   | BadRepositoryField RepositoryFieldError   | MissingDependencies (NonEmpty PackageName)-  | ParseAndDesugarError D.ParseDesugarError+  | CompileError P.MultipleErrors   | DirtyWorkingTree   deriving (Show) @@ -188,19 +187,9 @@         [ "Please install ", them, " first, by running `bower install`."         ])       ]-  ParseAndDesugarError (D.ParseError err) ->-    vcat-      [ para "Parse error:"-      , indented (P.prettyPrintMultipleErrorsBox False err)-      ]-  ParseAndDesugarError (D.SortModulesError err) ->-    vcat-      [ para "Error in sortModules:"-      , indented (P.prettyPrintMultipleErrorsBox False err)-      ]-  ParseAndDesugarError (D.DesugarError err) ->+  CompileError err ->     vcat-      [ para "Error while desugaring:"+      [ para "Compile error:"       , indented (P.prettyPrintMultipleErrorsBox False err)       ]   DirtyWorkingTree ->
src/Language/PureScript/Renamer.hs view
@@ -1,22 +1,9 @@------------------------------------------------------------------------------------------------------------------------------------------------------------------ Module      :  Language.PureScript.Renamer--- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- Renaming pass that prevents shadowing of local identifiers.---------------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} +-- |+-- Renaming pass that prevents shadowing of local identifiers.+-- module Language.PureScript.Renamer (renameInModules) where  import Prelude ()@@ -25,6 +12,7 @@ import Control.Monad.State  import Data.List (find)+import Data.Maybe (fromJust, fromMaybe)  import qualified Data.Map as M import qualified Data.Set as S@@ -76,19 +64,29 @@ -- unique name is generated and stored. -- updateScope :: Ident -> Rename Ident-updateScope i@(Ident name) | name == C.__unused = return i-updateScope name = do-  scope <- get-  name' <- if name `S.member` rsUsedNames scope-             then do-               let newNames = [ Ident (runIdent name ++ "_" ++ show (i :: Int)) | i <- [1..] ]-                   Just newName = find (`S.notMember` rsUsedNames scope) newNames-               return newName-             else return name-  modify $ \s -> s { rsBoundNames = M.insert name name' (rsBoundNames s)-                   , rsUsedNames  = S.insert name' (rsUsedNames s)-                   }-  return name'+updateScope ident =+  case ident of+    Ident name | name == C.__unused -> return ident+    GenIdent name _ -> go ident $ Ident (fromMaybe "v" name)+    _ -> go ident ident+  where+  go :: Ident -> Ident -> Rename Ident+  go keyName baseName = do+    scope <- get+    let usedNames = rsUsedNames scope+        name' =+          if baseName `S.member` usedNames+          then getNewName usedNames baseName+          else baseName+    modify $ \s -> s { rsBoundNames = M.insert keyName name' (rsBoundNames s)+                     , rsUsedNames  = S.insert name' (rsUsedNames s)+                     }+    return name'+  getNewName :: S.Set Ident -> Ident -> Ident+  getNewName usedNames name =+    fromJust $ find+      (`S.notMember` usedNames)+      [ Ident (runIdent name ++ show (i :: Int)) | i <- [1..] ]  -- | -- Finds the new name to use for an ident.
src/Language/PureScript/Sugar/BindingGroups.hs view
@@ -1,60 +1,61 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.BindingGroups--- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess--- License     :  MIT (http://opensource.org/licenses/MIT)------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :---+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+ -- | -- This module implements the desugaring pass which creates binding groups from sets of -- mutually-recursive value declarations and mutually-recursive type declarations. ----------------------------------------------------------------------------------{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Language.PureScript.Sugar.BindingGroups (-    createBindingGroups,-    createBindingGroupsModule,-    collapseBindingGroups,-    collapseBindingGroupsModule-) where+module Language.PureScript.Sugar.BindingGroups+  ( createBindingGroups+  , createBindingGroupsModule+  , collapseBindingGroups+  , collapseBindingGroupsModule+  ) where  import Prelude () import Prelude.Compat -import Data.Graph-import Data.List (nub, intersect)-import Data.Maybe (isJust, mapMaybe) import Control.Monad ((<=<)) import Control.Monad.Error.Class (MonadError(..)) +import Data.Graph+import Data.List (nub, intersect)+import Data.Maybe (isJust, mapMaybe) import qualified Data.Set as S -import Language.PureScript.Crash import Language.PureScript.AST-import Language.PureScript.Names-import Language.PureScript.Types+import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors+import Language.PureScript.Names+import Language.PureScript.Types  -- | -- Replace all sets of mutually-recursive declarations in a module with binding groups ---createBindingGroupsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]-createBindingGroupsModule = mapM $ \(Module ss coms name ds exps) -> Module ss coms name <$> createBindingGroups name ds <*> pure exps+createBindingGroupsModule+  :: (Functor m, Applicative m, MonadError MultipleErrors m)+  => [Module]+  -> m [Module]+createBindingGroupsModule =+  mapM $ \(Module ss coms name ds exps) ->+    Module ss coms name <$> createBindingGroups name ds <*> pure exps  -- | -- Collapse all binding groups in a module to individual declarations -- collapseBindingGroupsModule :: [Module] -> [Module]-collapseBindingGroupsModule = map $ \(Module ss coms name ds exps) -> Module ss coms name (collapseBindingGroups ds) exps+collapseBindingGroupsModule =+  map $ \(Module ss coms name ds exps) ->+    Module ss coms name (collapseBindingGroups ds) exps -createBindingGroups :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m) => ModuleName -> [Declaration] -> m [Declaration]+createBindingGroups+  :: forall m+   . (Functor m, Applicative m, MonadError MultipleErrors m)+  => ModuleName+  -> [Declaration]+  -> m [Declaration] createBindingGroups moduleName = mapM f <=< handleDecls    where@@ -71,8 +72,8 @@   handleDecls ds = do     let values = filter isValueDecl ds         dataDecls = filter isDataDecl ds-        allProperNames = map getProperName dataDecls-        dataVerts = map (\d -> (d, getProperName d, usedProperNames moduleName d `intersect` allProperNames)) dataDecls+        allProperNames = map getTypeName dataDecls+        dataVerts = map (\d -> (d, getTypeName d, usedTypeNames moduleName d `intersect` allProperNames)) dataDecls     dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup     let allIdents = map getIdent values         valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values@@ -90,11 +91,15 @@ -- Collapse all binding groups to individual declarations -- collapseBindingGroups :: [Declaration] -> [Declaration]-collapseBindingGroups = let (f, _, _) = everywhereOnValues id collapseBindingGroupsForValue id in map f . concatMap go+collapseBindingGroups =+  let (f, _, _) = everywhereOnValues id collapseBindingGroupsForValue id+  in map f . concatMap go   where   go (DataBindingGroupDeclaration ds) = ds-  go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds-  go (PositionedDeclaration pos com d) = map (PositionedDeclaration pos com) $ go d+  go (BindingGroupDeclaration ds) =+    map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds+  go (PositionedDeclaration pos com d) =+    map (PositionedDeclaration pos com) $ go d   go other = [other]  collapseBindingGroupsForValue :: Expr -> Expr@@ -102,21 +107,24 @@ collapseBindingGroupsForValue other = other  usedIdents :: ModuleName -> Declaration -> [Ident]-usedIdents moduleName =-  let (f, _, _, _, _) = everythingWithContextOnValues S.empty [] (++) def usedNamesE usedNamesB def def-  in nub . f+usedIdents moduleName = nub . usedIdents' S.empty . getValue   where-  def s _ = (s, [])+  def _ _ = [] -  usedNamesE :: S.Set Ident -> Expr -> (S.Set Ident, [Ident])-  usedNamesE scope (Var (Qualified Nothing name)) | name `S.notMember` scope = (scope, [name])-  usedNamesE scope (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' && name `S.notMember` scope = (scope, [name])-  usedNamesE scope (Abs (Left name) _) = (name `S.insert` scope, [])-  usedNamesE scope _ = (scope, [])+  getValue (ValueDeclaration _ _ [] (Right val)) = val+  getValue ValueDeclaration{} = internalError "Binders should have been desugared"+  getValue (PositionedDeclaration _ _ d) = getValue d+  getValue _ = internalError "Expected ValueDeclaration" -  usedNamesB :: S.Set Ident -> Binder -> (S.Set Ident, [Ident])-  usedNamesB scope binder = (scope `S.union` S.fromList (binderNames binder), [])+  (_, usedIdents', _, _, _) = everythingWithScope def usedNamesE def def def +  usedNamesE :: S.Set Ident -> Expr -> [Ident]+  usedNamesE scope (Var (Qualified Nothing name))+    | name `S.notMember` scope = [name]+  usedNamesE scope (Var (Qualified (Just moduleName') name))+    | moduleName == moduleName' && name `S.notMember` scope = [name]+  usedNamesE _ _ = []+ usedImmediateIdents :: ModuleName -> Declaration -> [Ident] usedImmediateIdents moduleName =   let (f, _, _, _, _) = everythingWithContextOnValues True [] (++) def usedNamesE def def def@@ -126,21 +134,24 @@    usedNamesE :: Bool -> Expr -> (Bool, [Ident])   usedNamesE True (Var (Qualified Nothing name)) = (True, [name])-  usedNamesE True (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = (True, [name])+  usedNamesE True (Var (Qualified (Just moduleName') name))+    | moduleName == moduleName' = (True, [name])   usedNamesE True (Abs _ _) = (False, [])   usedNamesE scope _ = (scope, []) -usedProperNames :: ModuleName -> Declaration -> [ProperName]-usedProperNames moduleName =+usedTypeNames :: ModuleName -> Declaration -> [ProperName 'TypeName]+usedTypeNames moduleName =   let (f, _, _, _, _) = accumTypes (everythingOnTypes (++) usedNames)   in nub . f   where-  usedNames :: Type -> [ProperName]-  usedNames (ConstrainedType constraints _) = flip mapMaybe constraints $ \qual ->-    case qual of-      (Qualified (Just moduleName') name, _) | moduleName == moduleName' -> Just name+  usedNames :: Type -> [ProperName 'TypeName]+  usedNames (ConstrainedType constraints _) =+    flip mapMaybe constraints $ \case+      (Qualified (Just moduleName') name, _)+        | moduleName == moduleName' -> Just (coerceProperName name)       _ -> Nothing-  usedNames (TypeConstructor (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]+  usedNames (TypeConstructor (Qualified (Just moduleName') name))+    | moduleName == moduleName' = [name]   usedNames _ = []  getIdent :: Declaration -> Ident@@ -148,17 +159,22 @@ getIdent (PositionedDeclaration _ _ d) = getIdent d getIdent _ = internalError "Expected ValueDeclaration" -getProperName :: Declaration -> ProperName-getProperName (DataDeclaration _ pn _ _) = pn-getProperName (TypeSynonymDeclaration pn _ _) = pn-getProperName (PositionedDeclaration _ _ d) = getProperName d-getProperName _ = internalError "Expected DataDeclaration"+getTypeName :: Declaration -> ProperName 'TypeName+getTypeName (DataDeclaration _ pn _ _) = pn+getTypeName (TypeSynonymDeclaration pn _ _) = pn+getTypeName (PositionedDeclaration _ _ d) = getTypeName d+getTypeName _ = internalError "Expected DataDeclaration"  -- | -- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration). -- ---toBindingGroup :: forall m. (Functor m, MonadError MultipleErrors m) => ModuleName -> SCC Declaration -> m Declaration+toBindingGroup+  :: forall m+   . (Functor m, MonadError MultipleErrors m)+   => ModuleName+   -> SCC Declaration+   -> m Declaration toBindingGroup _ (AcyclicSCC d) = return d toBindingGroup moduleName (CyclicSCC ds') =   -- Once we have a mutually-recursive group of declarations, we need to sort@@ -187,7 +203,10 @@   cycleError (ValueDeclaration n _ _ (Right _)) = errorMessage $ CycleInDeclaration n   cycleError _ = internalError "cycleError: Expected ValueDeclaration" -toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration+toDataBindingGroup+  :: MonadError MultipleErrors m+  => SCC Declaration+  -> m Declaration toDataBindingGroup (AcyclicSCC d) = return d toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of   Just pn -> throwError . errorMessage $ CycleInTypeSynonym (Just pn)@@ -196,7 +215,7 @@   | all (isJust . isTypeSynonym) ds' = throwError . errorMessage $ CycleInTypeSynonym Nothing   | otherwise = return $ DataBindingGroupDeclaration ds' -isTypeSynonym :: Declaration -> Maybe ProperName+isTypeSynonym :: Declaration -> Maybe (ProperName 'TypeName) isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn isTypeSynonym (PositionedDeclaration _ _ d) = isTypeSynonym d isTypeSynonym _ = Nothing
src/Language/PureScript/Sugar/CaseDeclarations.hs view
@@ -1,22 +1,10 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.CaseDeclarations--- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess--- License     :  MIT (http://opensource.org/licenses/MIT)------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :---+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+ -- | -- This module implements the desugaring pass which replaces top-level binders with -- case expressions. ----------------------------------------------------------------------------------{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}- module Language.PureScript.Sugar.CaseDeclarations (     desugarCases,     desugarCasesModule@@ -26,8 +14,8 @@ import Prelude.Compat  import Language.PureScript.Crash-import Data.Maybe (catMaybes)-import Data.List (nub, groupBy)+import Data.Maybe (catMaybes, mapMaybe)+import Data.List (nub, groupBy, foldl1')  import Control.Monad ((<=<), forM, replicateM, join, unless) import Control.Monad.Error.Class (MonadError(..))@@ -51,26 +39,54 @@ desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module] desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) ->   rethrow (addHint (ErrorInModule name)) $-    Module ss coms name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps+    Module ss coms name <$> (desugarCases <=< desugarAbs <=< validateCases $ ds) <*> pure exps -desugarAbs :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]+-- |+-- Validates that case head and binder lengths match.+--+validateCases :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]+validateCases = flip parU f+  where+  (f, _, _) = everywhereOnValuesM return validate return++  validate :: Expr -> m Expr+  validate c@(Case vs alts) = do+    let l = length vs+        alts' = filter ((l /=) . length . caseAlternativeBinders) alts+    unless (null alts') $+      throwError . MultipleErrors $ fmap (altError l) (caseAlternativeBinders <$> alts')+    return c+  validate other = return other++  altError :: Int -> [Binder] -> ErrorMessage+  altError l bs = withPosition pos $ ErrorMessage [] $ CaseBinderLengthDiffers l bs+    where+    pos = foldl1' widenSpan (mapMaybe positionedBinder bs)++    widenSpan (SourceSpan n start end) (SourceSpan _ start' end') =+      SourceSpan n (min start start') (max end end')++    positionedBinder (PositionedBinder p _ _) = Just p+    positionedBinder _ = Nothing++desugarAbs :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] desugarAbs = flip parU f   where   (f, _, _) = everywhereOnValuesM return replace return -  replace :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Expr -> m Expr+  replace :: Expr -> m Expr   replace (Abs (Right binder) val) = do-    ident <- Ident <$> freshName+    ident <- freshIdent'     return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)]   replace other = return other  -- | -- Replace all top-level binders with case expressions. ---desugarCases :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]+desugarCases :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup   where-    desugarRest :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]+    desugarRest :: [Declaration] -> m [Declaration]     desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =       (:) <$> (TypeInstanceDeclaration name constraints className tys <$> traverseTypeInstanceBody desugarCases ds) <*> desugarRest rest     desugarRest (ValueDeclaration name nameKind bs result : rest) =@@ -108,7 +124,7 @@   isVarBinder _ = False    fromVarBinder :: Binder -> m Ident-  fromVarBinder NullBinder = Ident <$> freshName+  fromVarBinder NullBinder = freshIdent'   fromVarBinder (VarBinder name) = return name   fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b   fromVarBinder (TypedBinder _ b) = fromVarBinder b@@ -134,24 +150,21 @@ makeCaseDeclaration :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration makeCaseDeclaration ident alternatives = do   let namedArgs = map findName . fst <$> alternatives-      argNames = map join $ foldl1 resolveNames namedArgs+      argNames = foldl1 resolveNames namedArgs   args <- if allUnique (catMaybes argNames)             then mapM argName argNames-            else replicateM (length argNames) (Ident <$> freshName)+            else replicateM (length argNames) freshIdent'   let vars = map (Var . Qualified Nothing) args       binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]       value = foldr (Abs . Left) (Case vars binders) args   return $ ValueDeclaration ident Public [] (Right value)   where   -- We will construct a table of potential names.-  -- VarBinders will become Just (Just _) which is a potential name.-  -- NullBinder will become Just Nothing, which indicates that we may-  -- have to generate a name.-  -- Everything else becomes Nothing, which indicates that we definitely+  -- VarBinders will become Just _ which is a potential name.+  -- Everything else becomes Nothing, which indicates that we   -- have to generate a name.-  findName :: Binder -> Maybe (Maybe Ident)-  findName NullBinder = Just Nothing-  findName (VarBinder name) = Just (Just name)+  findName :: Binder -> Maybe Ident+  findName (VarBinder name) = Just name   findName (PositionedBinder _ _ binder) = findName binder   findName _ = Nothing @@ -162,25 +175,17 @@    argName :: Maybe Ident -> m Ident   argName (Just name) = return name-  argName _ = do-    name <- freshName-    return (Ident name)+  argName _ = freshIdent'    -- Combine two lists of potential names from two case alternatives   -- by zipping correspoding columns.-  resolveNames :: [Maybe (Maybe Ident)] ->-                  [Maybe (Maybe Ident)] ->-                  [Maybe (Maybe Ident)]+  resolveNames :: [Maybe Ident] -> [Maybe Ident] -> [Maybe Ident]   resolveNames = zipWith resolveName    -- Resolve a pair of names. VarBinder beats NullBinder, and everything   -- else results in Nothing.-  resolveName :: Maybe (Maybe Ident) ->-                 Maybe (Maybe Ident) ->-                 Maybe (Maybe Ident)-  resolveName (Just (Just a)) (Just (Just b))-    | a == b = Just (Just a)+  resolveName :: Maybe Ident -> Maybe Ident -> Maybe Ident+  resolveName (Just a) (Just b)+    | a == b = Just a     | otherwise = Nothing-  resolveName (Just Nothing) a = a-  resolveName a (Just Nothing) = a   resolveName _ _ = Nothing
src/Language/PureScript/Sugar/DoNotation.hs view
@@ -1,22 +1,10 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Sugar.DoNotation--- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess--- License     :  MIT (http://opensource.org/licenses/MIT)------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :---+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+ -- | -- This module implements the desugaring pass which replaces do-notation statements with -- appropriate calls to bind from the Prelude.Monad type class. ----------------------------------------------------------------------------------{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}- module Language.PureScript.Sugar.DoNotation (     desugarDoModule ) where@@ -68,7 +56,7 @@     return $ App (App bind val) (Abs (Left ident) rest')   go (DoNotationBind binder val : rest) = do     rest' <- go rest-    ident <- Ident <$> freshName+    ident <- freshIdent'     return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')]))   go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet   go (DoNotationLet ds : rest) = do
src/Language/PureScript/Sugar/Names.hs view
@@ -1,21 +1,15 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Sugar.Names--- License     :  MIT (http://opensource.org/licenses/MIT)------ Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>--- Stability   :  experimental--- Portability :------ |---------------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} -module Language.PureScript.Sugar.Names (desugarImports) where+module Language.PureScript.Sugar.Names+  ( desugarImports+  , desugarImportsWithEnv+  , Env+  , Imports(..)+  , Exports(..)+  ) where  import Prelude () import Prelude.Compat@@ -29,6 +23,7 @@ import Control.Monad.State.Lazy  import qualified Data.Map as M+import qualified Data.Set as S  import Language.PureScript.Crash import Language.PureScript.AST@@ -47,10 +42,20 @@ -- modules should be topologically sorted beforehand. -- desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]-desugarImports externs modules = do+desugarImports externs modules =+  fmap snd (desugarImportsWithEnv externs modules)++desugarImportsWithEnv+  :: forall m+  . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)+  => [ExternsFile]+  -> [Module]+  -> m (Env, [Module])+desugarImportsWithEnv externs modules = do   env <- silence $ foldM externsEnv primEnv externs-  env' <- foldM updateEnv env modules-  traverse (renameInModule' env') modules+  modules' <- traverse updateExportRefs modules+  (modules'', env') <- foldM updateEnv ([], env) modules'+  (env',) <$> traverse (renameInModule' env') modules''   where   silence :: m a -> m a   silence = censor (const mempty)@@ -62,22 +67,22 @@         ss = internalModuleSourceSpan "<Externs>"         env' = M.insert efModuleName (ss, nullImports, members) env         fromEFImport (ExternsImport mn mt qmn) = (mn, [(Nothing, mt, qmn)])-    imps <- foldM (resolveModuleImport efModuleName env') nullImports (map fromEFImport efImports)+    imps <- foldM (resolveModuleImport env') nullImports (map fromEFImport efImports)     exps <- resolveExports env' efModuleName imps members efExports     return $ M.insert efModuleName (ss, imps, exps) env     where -    exportedTypes :: [((ProperName, [ProperName]), ModuleName)]+    exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]     exportedTypes = mapMaybe toExportedType efExports       where       toExportedType (TypeRef tyCon dctors) = Just ((tyCon, fromMaybe (mapMaybe forTyCon efDeclarations) dctors), efModuleName)         where-        forTyCon :: ExternsDeclaration -> Maybe ProperName+        forTyCon :: ExternsDeclaration -> Maybe (ProperName 'ConstructorName)         forTyCon (EDDataConstructor pn _ tNm _ _) | tNm == tyCon = Just pn         forTyCon _ = Nothing       toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r       toExportedType _ = Nothing-    exportedTypeClasses :: [(ProperName, ModuleName)]+    exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]     exportedTypeClasses = mapMaybe toExportedTypeClass efExports       where       toExportedTypeClass (TypeClassRef className) = Just (className, efModuleName)@@ -90,24 +95,24 @@       toExportedValue (PositionedDeclarationRef _ _ r) = toExportedValue r       toExportedValue _ = Nothing -  updateEnv :: Env -> Module -> m Env-  updateEnv env m@(Module ss _ mn _ refs) =+  updateEnv :: ([Module], Env) -> Module -> m ([Module], Env)+  updateEnv (ms, env) m@(Module ss _ mn _ refs) =     case mn `M.lookup` env of       Just m' -> throwError . errorMessage $ RedefinedModule mn [envModuleSourceSpan m', ss]       Nothing -> do         members <- findExportable m         let env' = M.insert mn (ss, nullImports, members) env-        imps <- resolveImports env' m+        (m', imps) <- resolveImports env' m         exps <- maybe (return members) (resolveExports env' mn imps members) refs-        return $ M.insert mn (ss, imps, exps) env+        return (m' : ms, M.insert mn (ss, imps, exps) env)    renameInModule' :: Env -> Module -> m Module   renameInModule' env m@(Module _ _ mn _ _) =     warnAndRethrow (addHint (ErrorInModule mn)) $ do       let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env       (m', used) <- flip runStateT M.empty $ renameInModule env imps (elaborateExports exps m)-      findUnusedImports m env used-      return $ elaborateImports imps m'+      lintImports m env used+      return m'  -- | -- Make all exports for a module explicit. This may still effect modules that@@ -128,34 +133,26 @@   my f = fst `map` filter ((== mn) . snd) (f exps)  -- |--- Add `import X ()` for any modules where there are only fully qualified references to members.--- This ensures transitive instances are included when using a member from a module.----elaborateImports :: Imports -> Module -> Module-elaborateImports imps (Module ss coms mn decls exps) = Module ss coms mn decls' exps-  where-  decls' :: [Declaration]-  decls' =-    let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues (const []) (const []) (const [])-    in mkImport `map` nub (f `concatMap` decls) ++ decls-  fqValues :: Expr -> [ModuleName]-  fqValues (Var (Qualified (Just mn') _)) | mn' `notElem` importedModules imps = [mn']-  fqValues _ = []-  mkImport :: ModuleName -> Declaration-  mkImport mn' = ImportDeclaration mn' (Explicit []) Nothing---- | -- Replaces all local names with qualified names within a module and checks that all existing -- qualified names are valid. ---renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m) => Env -> Imports -> Module -> m Module+renameInModule+  :: forall m+   . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m)+  => Env+  -> Imports+  -> Module+  -> m Module renameInModule env imports (Module ss coms mn decls exps) =   Module ss coms mn <$> parU decls go <*> pure exps   where    (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS -  updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> m ((Maybe SourceSpan, [Ident]), Declaration)+  updateDecl+    :: (Maybe SourceSpan, [Ident])+    -> Declaration+    -> m ((Maybe SourceSpan, [Ident]), Declaration)   updateDecl (_, bound) d@(PositionedDeclaration pos _ _) =     return ((Just pos, bound), d)   updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =@@ -170,9 +167,14 @@     (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty)   updateDecl (pos, bound) (ExternDeclaration name ty) =     (,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty)+  updateDecl (pos, bound) (FixityDeclaration fx name alias) =+    (,) (pos, bound) <$> (FixityDeclaration fx name <$> traverse (`updateValueName` pos) alias)   updateDecl s d = return (s, d)-  ---  updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> m ((Maybe SourceSpan, [Ident]), Expr)++  updateValue+    :: (Maybe SourceSpan, [Ident])+    -> Expr+    -> m ((Maybe SourceSpan, [Ident]), Expr)   updateValue (_, bound) v@(PositionedValue pos' _ _) =     return ((Just pos', bound), v)   updateValue (pos, bound) (Abs (Left arg) val') =@@ -192,8 +194,11 @@   updateValue s@(pos, _) (TypedValue check val ty) =     (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)   updateValue s v = return (s, v)-  ---  updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> m ((Maybe SourceSpan, [Ident]), Binder)++  updateBinder+    :: (Maybe SourceSpan, [Ident])+    -> Binder+    -> m ((Maybe SourceSpan, [Ident]), Binder)   updateBinder (_, bound) v@(PositionedBinder pos _ _) =     return ((Just pos, bound), v)   updateBinder s@(pos, _) (ConstructorBinder name b) =@@ -204,8 +209,11 @@     return (s', TypedBinder t' b')   updateBinder s v =     return (s, v)-  ---  updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative ->  m ((Maybe SourceSpan, [Ident]), CaseAlternative)++  updateCase+    :: (Maybe SourceSpan, [Ident])+    -> CaseAlternative+    -> m ((Maybe SourceSpan, [Ident]), CaseAlternative)   updateCase (pos, bound) c@(CaseAlternative bs _) =     return ((pos, concatMap binderNames bs ++ bound), c) @@ -225,17 +233,26 @@   updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint]   updateConstraints pos = traverse (\(name, ts) -> (,) <$> updateClassName name pos <*> traverse (updateTypesEverywhere pos) ts) -  updateTypeName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)-  updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) IsProperName+  updateTypeName+    :: Qualified (ProperName 'TypeName)+    -> Maybe SourceSpan+    -> m (Qualified (ProperName 'TypeName))+  updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) TyName (("type " ++) . runProperName) -  updateDataConstructorName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)-  updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) DctorName+  updateDataConstructorName+    :: Qualified (ProperName 'ConstructorName)+    -> Maybe SourceSpan+    -> m (Qualified (ProperName 'ConstructorName))+  updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) DctorName (("data constructor " ++) . runProperName) -  updateClassName  :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)-  updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) IsProperName+  updateClassName+    :: Qualified (ProperName 'ClassName)+    -> Maybe SourceSpan+    -> m (Qualified (ProperName 'ClassName))+  updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) TyClassName (("class " ++) . runProperName) -  updateValueName  :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)-  updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) IdentName+  updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)+  updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) IdentName (("value " ++) . runIdent)    -- Used when performing an update to qualify values and classes with their   -- module of original definition.@@ -244,54 +261,98 @@    -- Used when performing an update to qualify types with their module of   -- original definition.-  resolveType :: [((ProperName, [ProperName]), ModuleName)] -> ProperName -> Maybe (Qualified ProperName)+  resolveType+    :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]+    -> ProperName 'TypeName+    -> Maybe (Qualified (ProperName 'TypeName))   resolveType tys name = mkQualified name . snd <$> find ((== name) . fst . fst) tys    -- Used when performing an update to qualify data constructors with their   -- module of original definition.-  resolveDctor :: [((ProperName, [ProperName]), ModuleName)] -> ProperName -> Maybe (Qualified ProperName)+  resolveDctor+    :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]+    -> ProperName 'ConstructorName+    -> Maybe (Qualified (ProperName 'ConstructorName))   resolveDctor tys name = mkQualified name . snd <$> find (elem name . snd . fst) tys    -- Update names so unqualified references become qualified, and locally   -- qualified references are replaced with their canoncial qualified names   -- (e.g. M.Map -> Data.Map.Map).-  update :: (Ord a) => (Qualified a -> SimpleErrorMessage)-                       -> M.Map (Qualified a) (Qualified a, ModuleName)-                       -> (Exports -> a -> Maybe (Qualified a))-                       -> (Qualified a -> Name)-                       -> Qualified a-                       -> Maybe SourceSpan-                       -> m (Qualified a)-  update unknown imps getE toName qname@(Qualified mn' name) pos = positioned $+  update+    :: (Ord a, Show a)+    => (Qualified a -> SimpleErrorMessage)+    -> M.Map (Qualified a) [(Qualified a, ModuleName)]+    -> (Exports -> a -> Maybe (Qualified a))+    -> (Qualified a -> Name)+    -> (a -> String)+    -> Qualified a+    -> Maybe SourceSpan+    -> m (Qualified a)+  update unknown imps getE toName render qname@(Qualified mn' name) pos = positioned $     case (M.lookup qname imps, mn') of+       -- We found the name in our imports, so we return the name for it,       -- qualifying with the name of the module it was originally defined in       -- rather than the module we're importing from, to handle the case of-      -- re-exports.-      (Just (qn, mnOrig), _) -> do-        case qn of-          Qualified (Just mnNew) _ ->-            modify $ \result -> M.insert mnNew (maybe [toName qname] (toName qname :) (mnNew `M.lookup` result)) result-          _ -> return ()+      -- re-exports. If there are multiple options for the name to resolve to+      -- in scope, we throw an error.+      (Just options, _) -> do+        checkImportConflicts render options+        let (Qualified (Just mnNew) _, mnOrig) = head options+        modify $ \result -> M.insert mnNew (maybe [toName qname] (toName qname :) (mnNew `M.lookup` result)) result         return $ Qualified (Just mnOrig) name+       -- If the name wasn't found in our imports but was qualified then we need       -- to check whether it's a failed import from a "pseudo" module (created       -- by qualified importing). If that's not the case, then we just need to       -- check it refers to a symbol in another module.       (Nothing, Just mn'') -> do-        when (isExplicitQualModule mn'') . throwError . errorMessage $ unknown qname-        modExports <- getExports mn''-        maybe (throwError . errorMessage $ unknown qname) return (getE modExports name)+        case M.lookup mn'' env of+          Nothing+            | mn'' `S.member` importedVirtualModules imports -> throwUnknown+            | otherwise -> throwError . errorMessage $ UnknownModule mn''+          Just env' -> maybe throwUnknown return (getE (envModuleExports env') name)+       -- If neither of the above cases are true then it's an undefined or       -- unimported symbol.-      _ -> throwError . errorMessage $ unknown qname+      _ -> throwUnknown+     where-    isExplicitQualModule :: ModuleName -> Bool-    isExplicitQualModule = flip elem $ mapMaybe (\(Qualified q _) -> q) (M.keys imps)     positioned err = case pos of       Nothing -> err       Just pos' -> rethrowWithPosition pos' err+    throwUnknown = throwError . errorMessage $ unknown qname -  -- Gets the exports for a module, or an error message if the module doesn't exist-  getExports :: ModuleName -> m Exports-  getExports mn' = maybe (throwError . errorMessage $ UnknownModule mn') (return . envModuleExports) $ M.lookup mn' env+-- |+-- Replaces `ProperRef` export values with a `TypeRef` or `TypeClassRef`+-- depending on what is availble within the module. Warns when a `ProperRef`+-- desugars into a `TypeClassRef`.+--+updateExportRefs+  :: forall m+   . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)+   => Module+   -> m Module+updateExportRefs (Module ss coms mn decls exps) =+  Module ss coms mn decls <$> traverse (traverse updateRef) exps+  where++  updateRef :: DeclarationRef -> m DeclarationRef+  updateRef (ProperRef name)+     | ProperName name `elem` classNames = do+        tell . errorMessage . DeprecatedClassExport $ ProperName name+        return . TypeClassRef $ ProperName name+       -- Fall through case here - assume it's a type if it's not a class.+       -- If it's a reference to something that doesn't actually exist it will+       -- be picked up elsewhere+     | otherwise = return $ TypeRef (ProperName name) (Just [])+  updateRef (PositionedDeclarationRef pos com ref) =+    warnWithPosition pos $ PositionedDeclarationRef pos com <$> updateRef ref+  updateRef other = return other++  classNames :: [ProperName 'ClassName]+  classNames = mapMaybe go decls+    where+    go (PositionedDeclaration _ _ d) = go d+    go (TypeClassDeclaration name _ _ _) = Just name+    go _ = Nothing
src/Language/PureScript/Sugar/Names/Env.hs view
@@ -1,17 +1,5 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Sugar.Names.Env--- License     :  MIT (http://opensource.org/licenses/MIT)------ Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>--- Stability   :  experimental--- Portability :------ |---------------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Language.PureScript.Sugar.Names.Env   ( Imports(..)@@ -26,14 +14,21 @@   , exportType   , exportTypeClass   , exportValue+  , getExports+  , checkImportConflicts   ) where +import Data.Function (on)+import Data.List (groupBy, sortBy, nub)+import Data.Maybe (fromJust) import qualified Data.Map as M+import qualified Data.Set as S  import Control.Monad import Control.Monad.Error.Class (MonadError(..))  import Language.PureScript.AST+import Language.PureScript.Crash import Language.PureScript.Names import Language.PureScript.Environment import Language.PureScript.Errors@@ -46,30 +41,35 @@   -- |   -- Local names for types within a module mapped to to their qualified names   ---    importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName)+    importedTypes :: M.Map (Qualified (ProperName 'TypeName)) [(Qualified (ProperName 'TypeName), ModuleName)]   -- |   -- Local names for data constructors within a module mapped to to their qualified names   ---  , importedDataConstructors :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName)+  , importedDataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) [(Qualified (ProperName 'ConstructorName), ModuleName)]   -- |   -- Local names for classes within a module mapped to to their qualified names   ---  , importedTypeClasses :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName)+  , importedTypeClasses :: M.Map (Qualified (ProperName 'ClassName)) [(Qualified (ProperName 'ClassName), ModuleName)]   -- |   -- Local names for values within a module mapped to to their qualified names   ---  , importedValues :: M.Map (Qualified Ident) (Qualified Ident, ModuleName)+  , importedValues :: M.Map (Qualified Ident) [(Qualified Ident, ModuleName)]   -- |-  -- The list of modules that have been imported into the current scope.+  -- The modules that have been imported into the current scope.   ---  , importedModules :: [ModuleName]+  , importedModules :: S.Set ModuleName+  -- |+  -- The names of "virtual" modules that come into existence when "import as"+  -- is used.+  --+  , importedVirtualModules :: S.Set ModuleName   } deriving (Show, Read)  -- | -- An empty 'Imports' value. -- nullImports :: Imports-nullImports = Imports M.empty M.empty M.empty M.empty []+nullImports = Imports M.empty M.empty M.empty M.empty S.empty S.empty  -- | -- The exported declarations from a module.@@ -80,12 +80,12 @@   -- The types exported from each module along with the module they originally   -- came from.   ---    exportedTypes :: [((ProperName, [ProperName]), ModuleName)]+    exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]   -- |   -- The classes exported from each module along with the module they originally   -- came from.   ---  , exportedTypeClasses :: [(ProperName, ModuleName)]+  , exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]   -- |   -- The values exported from each module along with the module they originally   -- came from.@@ -128,9 +128,10 @@ -- The exported types from the @Prim@ module -- primExports :: Exports-primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] []+primExports = Exports (mkTypeEntry `map` M.keys primTypes) (mkClassEntry `map` M.keys primClasses) []   where-  mkTypeEntry (Qualified _ name) = ((name, []), ModuleName [ProperName "Prim"])+  mkTypeEntry (Qualified mn name) = ((name, []), fromJust mn)+  mkClassEntry (Qualified mn name) = (name, fromJust mn)  -- | Environment which only contains the Prim module. primEnv :: Env@@ -142,27 +143,28 @@ -- Safely adds a type and its data constructors to some exports, returning an -- error if a conflict occurs. ---exportType :: (MonadError MultipleErrors m) => Exports -> ProperName -> [ProperName] -> ModuleName -> m Exports+exportType :: (MonadError MultipleErrors m) => Exports -> ProperName 'TypeName -> [ProperName 'ConstructorName] -> ModuleName -> m Exports exportType exps name dctors mn = do-  let exTypes = exportedTypes exps+  let exTypes' = exportedTypes exps+  let exTypes = filter ((/= mn) . snd) exTypes'   let exDctors = (snd . fst) `concatMap` exTypes   let exClasses = exportedTypeClasses exps-  when (any (\((name', _), _) -> name == name') exTypes) $ throwConflictError ConflictingTypeDecls name-  when (any ((== name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name+  when (any ((== name) . fst . fst) exTypes) $ throwConflictError ConflictingTypeDecls name+  when (any ((== coerceProperName name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name   forM_ dctors $ \dctor -> do     when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor-    when (any ((== dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor-  return $ exps { exportedTypes = ((name, dctors), mn) : exTypes }+    when (any ((== coerceProperName dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor+  return $ exps { exportedTypes = nub $ ((name, dctors), mn) : exTypes' }  -- | -- Safely adds a class to some exports, returning an error if a conflict occurs. ---exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName -> ModuleName -> m Exports+exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName 'ClassName -> ModuleName -> m Exports exportTypeClass exps name mn = do   let exTypes = exportedTypes exps   let exDctors = (snd . fst) `concatMap` exTypes-  when (any (\((name', _), _) -> name == name') exTypes) $ throwConflictError ClassConflictsWithType name-  when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name+  when (any ((== coerceProperName name) . fst . fst) exTypes) $ throwConflictError ClassConflictsWithType name+  when (coerceProperName name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name   classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps)   return $ exps { exportedTypeClasses = classes } @@ -180,12 +182,39 @@ -- addExport :: (MonadError MultipleErrors m, Eq a) => (a -> SimpleErrorMessage) -> a -> ModuleName -> [(a, ModuleName)] -> m [(a, ModuleName)] addExport what name mn exports =-  if any ((== name) . fst) exports+  if any (\(name', mn') -> name == name' && mn /= mn') exports   then throwConflictError what name-  else return $ (name, mn) : exports+  else return $ nub $ (name, mn) : exports  -- | -- Raises an error for when there is more than one definition for something. -- throwConflictError :: (MonadError MultipleErrors m) => (a -> SimpleErrorMessage) -> a -> m b throwConflictError conflict = throwError . errorMessage . conflict++-- Gets the exports for a module, or an error message if the module doesn't exist+getExports :: (MonadError MultipleErrors m) => Env -> ModuleName -> m Exports+getExports env mn = maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ M.lookup mn env++-- |+-- When reading a value from the imports, check that there are no conflicts in+-- scope.+--+checkImportConflicts+  :: forall m a+   . (MonadError MultipleErrors m, Ord a)+  => (a -> String)+  -> [(Qualified a, ModuleName)]+  -> m ()+checkImportConflicts render xs =+  let byOrig = groupBy ((==) `on` snd) . sortBy (compare `on` snd) $ xs+  in+    if length byOrig > 1+    then throwError . errorMessage $ ScopeConflict (render' (fst . head $ xs)) (map (getQual . fst . head) byOrig)+    else return ()+  where+  getQual :: Qualified a -> ModuleName+  getQual (Qualified (Just mn) _) = mn+  getQual _ = internalError "unexpected unqualified name in checkImportConflicts"+  render' :: Qualified a -> String+  render' (Qualified _ a) = render a
src/Language/PureScript/Sugar/Names/Exports.hs view
@@ -1,20 +1,8 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Sugar.Names.Exports--- License     :  MIT (http://opensource.org/licenses/MIT)------ Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>--- Stability   :  experimental--- Portability :------ |---------------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE LambdaCase #-}  module Language.PureScript.Sugar.Names.Exports   ( findExportable@@ -29,6 +17,7 @@ import Data.Foldable (traverse_)  import Control.Monad+import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Error.Class (MonadError(..))  import qualified Data.Map as M@@ -58,6 +47,7 @@   updateExports exps (TypeSynonymDeclaration tn _ _) = exportType exps tn [] mn   updateExports exps (ExternDataDeclaration tn _) = exportType exps tn [] mn   updateExports exps (ValueDeclaration name _ _ _) = exportValue exps name mn+  updateExports exps (FixityDeclaration _ name (Just _)) = exportValue exps (Op name) mn   updateExports exps (ExternDeclaration name _) = exportValue exps name mn   updateExports exps (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ updateExports exps d   updateExports exps _ = return exps@@ -66,14 +56,31 @@ -- Resolves the exports for a module, filtering out members that have not been -- exported and elaborating re-exports of other modules. ---resolveExports :: forall m. (Applicative m, MonadError MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports+resolveExports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports resolveExports env mn imps exps refs =   rethrow (addHint (ErrorInModule mn)) $ do     filtered <- filterModule mn exps refs+    let (dupeRefs, dupeDctors) = findDuplicateRefs refs+    warnDupeRefs dupeRefs+    warnDupeDctors dupeDctors     foldM elaborateModuleExports filtered refs    where +  warnDupeRefs :: [DeclarationRef] -> m ()+  warnDupeRefs = traverse_ $ \case+    TypeRef name _ -> warnDupe $ "type " ++ runProperName name+    ValueRef name -> warnDupe $ "value " ++ runIdent name+    TypeClassRef name -> warnDupe $ "class " ++ runProperName name+    ModuleRef name -> warnDupe $ "module " ++ runModuleName name+    _ -> return ()++  warnDupeDctors :: [ProperName 'ConstructorName] -> m ()+  warnDupeDctors = traverse_ (warnDupe . ("data constructor " ++) . runProperName)++  warnDupe :: String -> m ()+  warnDupe ref = tell . errorMessage $ DuplicateExportRef ref+   -- Takes the current module's imports, the accumulated list of exports, and a   -- `DeclarationRef` for an explicit export. When the ref refers to another   -- module, export anything from the imports that matches for that module.@@ -91,20 +98,30 @@     let isPseudo = isPseudoModule name     when (not isPseudo && not (isImportedModule name)) $       throwError . errorMessage . UnknownExportModule $ name-    let reTypes = extract isPseudo name (importedTypes imps)-    let reDctors = extract isPseudo name (importedDataConstructors imps)-    let reClasses = extract isPseudo name (importedTypeClasses imps)-    let reValues = extract isPseudo name (importedValues imps)+    reTypes <- extract isPseudo name (("type " ++) . runProperName) (importedTypes imps)+    reDctors <- extract isPseudo name (("data constructor " ++) . runProperName) (importedDataConstructors imps)+    reClasses <- extract isPseudo name (("class " ++) . runProperName) (importedTypeClasses imps)+    reValues <- extract isPseudo name (("value " ++) . runIdent) (importedValues imps)     result' <- foldM (\exps' ((tctor, dctors), mn') -> exportType exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors)     result'' <- foldM (uncurry . exportTypeClass) result' (map resolveClass reClasses)     foldM (uncurry . exportValue) result'' (map resolveValue reValues)   elaborateModuleExports result _ = return result    -- Extracts a list of values for a module based on a lookup table. If the-  -- boolean is true the values are filtered by the qualification of the-  extract :: Bool -> ModuleName -> M.Map (Qualified a) (Qualified a, ModuleName) -> [Qualified a]-  extract True name = map fst . M.elems . M.filterWithKey (\k _ -> eqQual name k)-  extract False name = map fst . M.elems . M.filter (eqQual name . fst)+  -- boolean is true the values are filtered by the qualification+  extract+    :: (Ord a)+    => Bool+    -> ModuleName+    -> (a -> String)+    -> M.Map (Qualified a) [(Qualified a, ModuleName)]+    -> m [Qualified a]+  extract useQual name render = fmap (map (fst . head . snd)) . go . M.toList+    where+    go = filterM $ \(name', options) -> do+      let isMatch = if useQual then eqQual name name' else any (eqQual name . fst) options+      when (isMatch && length options > 1) $ checkImportConflicts render options+      return isMatch    -- Check whether a module name refers to a "pseudo module" that came into   -- existence in an import scope due to importing one or more modules as@@ -116,7 +133,7 @@     -- function to either extract the keys or values. We test the keys to see if a     -- value being re-exported belongs to a qualified module, and we test the     -- values if that fails to see whether the value has been imported at all.-    testQuals :: (forall a. M.Map (Qualified a) (Qualified a, ModuleName) -> [Qualified a]) -> ModuleName -> Bool+    testQuals :: (forall a b. M.Map (Qualified a) b -> [Qualified a]) -> ModuleName -> Bool     testQuals f mn' = any (eqQual mn') (f (importedTypes imps))                    || any (eqQual mn') (f (importedDataConstructors imps))                    || any (eqQual mn') (f (importedTypeClasses imps))@@ -134,21 +151,26 @@    -- Constructs a list of types with their data constructors and the original   -- module they were defined in from a list of type and data constructor names.-  resolveTypeExports :: [Qualified ProperName] -> [Qualified ProperName] -> [((ProperName, [ProperName]), ModuleName)]+  resolveTypeExports+    :: [Qualified (ProperName 'TypeName)]+    -> [Qualified (ProperName 'ConstructorName)]+    -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]   resolveTypeExports tctors dctors = map go tctors     where-    go :: Qualified ProperName -> ((ProperName, [ProperName]), ModuleName)+    go+      :: Qualified (ProperName 'TypeName)+      -> ((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)     go (Qualified (Just mn'') name) = fromMaybe (internalError "Missing value in resolveTypeExports") $ do       exps' <- envModuleExports <$> mn'' `M.lookup` env       ((_, dctors'), mnOrig) <- find (\((name', _), _) -> name == name') (exportedTypes exps')-      let relevantDctors = mapMaybe (\(Qualified mn''' dctor) -> if mn''' == Just mnOrig then Just dctor else Nothing) dctors+      let relevantDctors = mapMaybe (\(Qualified mn''' dctor) -> if mn''' == Just mn'' then Just dctor else Nothing) dctors       return ((name, intersect relevantDctors dctors'), mnOrig)     go (Qualified Nothing _) = internalError "Unqualified value in resolveTypeExports"     -- Looks up an imported class and re-qualifies it with the original module it   -- came from.-  resolveClass :: Qualified ProperName -> (ProperName, ModuleName)+  resolveClass :: Qualified (ProperName 'ClassName) -> (ProperName 'ClassName, ModuleName)   resolveClass className = splitQual $ fromMaybe (internalError "Missing value in resolveClass") $     resolve exportedTypeClasses className @@ -175,7 +197,13 @@ -- Filters the full list of exportable values, types, and classes for a module -- based on a list of export declaration references. ---filterModule :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> Exports -> [DeclarationRef] -> m Exports+filterModule+  :: forall m+   . (Applicative m, MonadError MultipleErrors m)+  => ModuleName+  -> Exports+  -> [DeclarationRef]+  -> m Exports filterModule mn exps refs = do   types <- foldM (filterTypes $ exportedTypes exps) [] refs   values <- foldM (filterValues $ exportedValues exps) [] refs@@ -189,7 +217,11 @@   -- explicit export. When the ref refers to a type in the list of exportable   -- values, the type and specified data constructors are included in the   -- result.-  filterTypes :: [((ProperName, [ProperName]), ModuleName)] -> [((ProperName, [ProperName]), ModuleName)] -> DeclarationRef -> m [((ProperName, [ProperName]), ModuleName)]+  filterTypes+    :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]+    -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]+    -> DeclarationRef+    -> m [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]   filterTypes exps' result (PositionedDeclarationRef pos _ r) =     rethrowWithPosition pos $ filterTypes exps' result r   filterTypes exps' result (TypeRef name expDcons) =@@ -204,7 +236,11 @@   -- Ensures a data constructor is exportable for a given type. Takes a type   -- name, a list of exportable data constructors for the type, and the name of   -- the data constructor to check.-  checkDcon :: ProperName -> [ProperName] -> ProperName -> m ()+  checkDcon+    :: ProperName 'TypeName+    -> [ProperName 'ConstructorName]+    -> ProperName 'ConstructorName+    -> m ()   checkDcon tcon exps' name =     unless (name `elem` exps') $       throwError . errorMessage $ UnknownExportDataConstructor tcon name@@ -213,7 +249,11 @@   -- filtered exports, and a `DeclarationRef` for an explicit export. When the   -- ref refers to a class in the list of exportable classes, the class is   -- included in the result.-  filterClasses :: [(ProperName, ModuleName)] -> [(ProperName, ModuleName)] -> DeclarationRef -> m [(ProperName, ModuleName)]+  filterClasses+    :: [(ProperName 'ClassName, ModuleName)]+    -> [(ProperName 'ClassName, ModuleName)]+    -> DeclarationRef+    -> m [(ProperName 'ClassName, ModuleName)]   filterClasses exps' result (PositionedDeclarationRef pos _ r) =     rethrowWithPosition pos $ filterClasses exps' result r   filterClasses exps' result (TypeClassRef name) =
src/Language/PureScript/Sugar/Names/Imports.hs view
@@ -1,19 +1,7 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Sugar.Names.Imports--- License     :  MIT (http://opensource.org/licenses/MIT)------ Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>--- Stability   :  experimental--- Portability :------ |---------------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE LambdaCase #-}  module Language.PureScript.Sugar.Names.Imports   ( resolveImports@@ -24,16 +12,18 @@ import Prelude () import Prelude.Compat -import Data.List (find)-import Data.Maybe (fromMaybe, isNothing)-import Data.Foldable (traverse_)+import Data.List (find, delete, (\\))+import Data.Maybe (fromMaybe, isJust, isNothing, fromJust)+import Data.Foldable (traverse_, for_)+import Data.Traversable (for)  import Control.Arrow (first) import Control.Monad import Control.Monad.Error.Class (MonadError(..))-import Control.Monad.Writer (MonadWriter(..), censor)+import Control.Monad.Writer (MonadWriter(..))  import qualified Data.Map as M+import qualified Data.Set as S  import Language.PureScript.Crash import Language.PureScript.AST@@ -45,46 +35,145 @@ -- Finds the imports within a module, mapping the imported module name to an optional set of -- explicitly imported declarations. ---findImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Declaration] -> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])+findImports+  :: forall m+   . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)+  => [Declaration]+  -> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) findImports = foldM (go Nothing) M.empty   where-  go pos result (ImportDeclaration mn typ qual) = do-    checkImportRefType typ+  go pos result (ImportDeclaration mn typ qual isOldSyntax) = do+    when isOldSyntax . tell . errorMessage $ DeprecatedQualifiedSyntax mn (fromJust qual)     let imp = (pos, typ, qual)     return $ M.insert mn (maybe [imp] (imp :) (mn `M.lookup` result)) result-  go _ result (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go (Just pos) result d+  go _ result (PositionedDeclaration pos _ d) = warnAndRethrowWithPosition pos $ go (Just pos) result d   go _ result _ = return result -  -- Ensure that classes don't appear in an `import X hiding (...)`-  checkImportRefType :: ImportDeclarationType -> m ()-  checkImportRefType (Hiding refs) = traverse_ checkImportRef refs-  checkImportRefType _ = return ()-  checkImportRef :: DeclarationRef -> m ()-  checkImportRef (ModuleRef name) = throwError . errorMessage $ ImportHidingModule name-  checkImportRef _ = return ()+type ImportDef = (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)  -- | -- Constructs a set of imports for a module. ---resolveImports :: (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> Module -> m Imports-resolveImports env (Module _ _ currentModule decls _) =-  censor (addHint (ErrorInModule currentModule)) $ do-    scope <- M.insert currentModule [(Nothing, Implicit, Nothing)] <$> findImports decls-    foldM (resolveModuleImport currentModule env) nullImports (M.toList scope)+resolveImports+  :: forall m+   . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)+  => Env+  -> Module+  -> m (Module, Imports)+resolveImports env (Module ss coms currentModule decls exps) =+  warnAndRethrow (addHint (ErrorInModule currentModule)) $ do +    decls' <- traverse updateImportRef decls+    imports <- findImports decls'++    for_ (M.toList imports) $ \(mn, imps) -> do++      -- Better ordering for the warnings: the list is in last-import-first+      -- order, but we want the first appearence of an import to be the primary,+      -- and warnings to appear for later imports+      let imps' = reverse imps++      warned <- foldM (checkDuplicateImports mn) [] (selfCartesianSubset imps')++      let unqual = filter (\(_, _, q) -> isJust q) (imps' \\ warned)++      warned' <- (warned ++) <$>+        if (length unqual < 2)+        then return []+        else case find (\(_, typ, _) -> isImplicit typ) unqual of+          Just i ->+            for (delete i unqual) $ \i'@(pos, typ, _) -> do+              warn pos $ RedundantUnqualifiedImport mn typ+              return i'+          Nothing ->+            for (tail unqual) $ \i@(pos, _, _) -> do+              warn pos $ DuplicateSelectiveImport mn+              return i++      for_ (imps' \\ warned') $ \(pos, typ, _) ->+        let (dupeRefs, dupeDctors) = findDuplicateRefs $ case typ of+              Explicit refs -> refs+              Hiding refs -> refs+              _ -> []+        in warnDupeRefs pos dupeRefs >> warnDupeDctors pos dupeDctors++      return ()++    let scope = M.insert currentModule [(Nothing, Implicit, Nothing)] imports+    resolved <- foldM (resolveModuleImport env) nullImports (M.toList scope)+    return (Module ss coms currentModule decls' exps, resolved)++  where+  selfCartesianSubset :: [a] -> [(a, a)]+  selfCartesianSubset (x : xs) = [(x, y) | y <- xs] ++ selfCartesianSubset xs+  selfCartesianSubset [] = []++  checkDuplicateImports :: ModuleName -> [ImportDef] -> (ImportDef, ImportDef) -> m [ImportDef]+  checkDuplicateImports mn xs ((_, t1, q1), (pos, t2, q2)) =+    if (t1 == t2 && q1 == q2)+    then do+      warn pos $ DuplicateImport mn t2 q2+      return $ (pos, t2, q2) : xs+    else return xs++  warnDupeRefs :: Maybe SourceSpan -> [DeclarationRef] -> m ()+  warnDupeRefs pos = traverse_ $ \case+    TypeRef name _ -> warnDupe pos $ "type " ++ runProperName name+    ValueRef name -> warnDupe pos $ "value " ++ runIdent name+    TypeClassRef name -> warnDupe pos $ "class " ++ runProperName name+    ModuleRef name -> warnDupe pos $ "module " ++ runModuleName name+    _ -> return ()++  warnDupeDctors :: Maybe SourceSpan -> [ProperName 'ConstructorName] -> m ()+  warnDupeDctors pos = traverse_ (warnDupe pos . ("data constructor " ++) . runProperName)++  warnDupe :: Maybe SourceSpan -> String -> m ()+  warnDupe pos ref = warn pos $ DuplicateImportRef ref++  warn :: Maybe SourceSpan -> SimpleErrorMessage -> m ()+  warn pos msg = maybe id warnWithPosition pos $ tell . errorMessage $ msg++  updateImportRef :: Declaration -> m Declaration+  updateImportRef (PositionedDeclaration pos com d) =+    warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> updateImportRef d+  updateImportRef (ImportDeclaration mn typ qual isOldSyntax) = do+    modExports <- getExports env mn+    typ' <- case typ of+      Implicit -> return Implicit+      Explicit refs -> Explicit <$> updateProperRef mn modExports `traverse` refs+      Hiding refs -> Hiding <$> updateProperRef mn modExports `traverse` refs+    return $ ImportDeclaration mn typ' qual isOldSyntax+  updateImportRef other = return other++  updateProperRef :: ModuleName -> Exports -> DeclarationRef -> m DeclarationRef+  updateProperRef importModule modExports (ProperRef name) =+    if ProperName name `elem` (fst `map` exportedTypeClasses modExports)+    then do+      tell . errorMessage $ DeprecatedClassImport importModule (ProperName name)+      return . TypeClassRef $ ProperName name+    else return $ TypeRef (ProperName name) (Just [])+  updateProperRef importModule modExports (PositionedDeclarationRef pos com ref) =+    PositionedDeclarationRef pos com <$> updateProperRef importModule modExports ref+  updateProperRef _ _ other = return other+ -- | Constructs a set of imports for a single module import.-resolveModuleImport ::-  forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>-  ModuleName -> Env -> Imports ->-  (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) ->-  m Imports-resolveModuleImport currentModule env ie (mn, imps) = foldM go ie imps+resolveModuleImport+  :: forall m+   . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)+  => Env+  -> Imports+  -> (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])+  -> m Imports+resolveModuleImport env ie (mn, imps) = foldM go ie imps   where   go :: Imports -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m Imports   go ie' (pos, typ, impQual) = do     modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env-    let ie'' = ie' { importedModules = mn : importedModules ie' }-    positioned $ resolveImport currentModule mn modExports ie'' impQual typ+    let virtualModules = importedVirtualModules ie'+        ie'' = ie' { importedModules = S.insert mn (importedModules ie')+                   , importedVirtualModules = maybe virtualModules (`S.insert` virtualModules) impQual+                   }+    positioned $ resolveImport mn modExports ie'' impQual typ     where     positioned err = case pos of       Nothing -> err@@ -93,19 +182,34 @@ -- | -- Extends the local environment for a module by resolving an import of another module. ---resolveImport :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> ModuleName -> Exports -> Imports -> Maybe ModuleName -> ImportDeclarationType -> m Imports-resolveImport currentModule importModule exps imps impQual =-  resolveByType+resolveImport+  :: forall m+   . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)+  => ModuleName+  -> Exports+  -> Imports+  -> Maybe ModuleName+  -> ImportDeclarationType+  -> m Imports+resolveImport importModule exps imps impQual = resolveByType   where    resolveByType :: ImportDeclarationType -> m Imports   resolveByType Implicit = importAll importExplicit-  resolveByType (Explicit explImports) = checkRefs explImports >> foldM importExplicit imps explImports-  resolveByType (Hiding hiddenImports) = checkRefs hiddenImports >> importAll (importNonHidden hiddenImports)+  resolveByType (Explicit refs) = checkRefs False refs >> foldM importExplicit imps refs+  resolveByType (Hiding refs) = do+    imps' <- checkRefs True refs >> importAll (importNonHidden refs)+    let isEmptyImport+           = M.null (importedTypes imps')+          && M.null (importedDataConstructors imps')+          && M.null (importedTypeClasses imps')+          && M.null (importedValues imps')+    when isEmptyImport $ tell . errorMessage $ RedundantEmptyHidingImport importModule+    return imps'    -- Check that a 'DeclarationRef' refers to an importable symbol-  checkRefs :: [DeclarationRef] -> m ()-  checkRefs = traverse_ check+  checkRefs :: Bool -> [DeclarationRef] -> m ()+  checkRefs isHiding = traverse_ check     where     check (PositionedDeclarationRef pos _ r) =       rethrowWithPosition pos $ check r@@ -117,18 +221,27 @@       maybe (return ()) (traverse_ $ checkDctorExists name allDctors) dctors     check (TypeClassRef name) =       checkImportExists UnknownImportTypeClass (fst `map` exportedTypeClasses exps) name-    --check (ModuleRef name) =-    --  checkImportExists (const UnknownModule) (exportedModules exps) name-    check _ = internalError "Invalid argument to checkRefs"+    check (ModuleRef name) | isHiding =+      throwError . errorMessage $ ImportHidingModule name+    check r = internalError $ "Invalid argument to checkRefs: " ++ show r    -- Check that an explicitly imported item exists in the module it is being imported from-  checkImportExists :: (Eq a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m ()+  checkImportExists+    :: Eq a+    => (ModuleName -> a -> SimpleErrorMessage)+    -> [a]+    -> a+    -> m ()   checkImportExists unknown exports item =     when (item `notElem` exports) $ throwError . errorMessage $ unknown importModule item    -- Ensure that an explicitly imported data constructor exists for the type it is being imported   -- from-  checkDctorExists :: ProperName -> [ProperName] -> ProperName -> m ()+  checkDctorExists+    :: ProperName 'TypeName+    -> [ProperName 'ConstructorName]+    -> ProperName 'ConstructorName+    -> m ()   checkDctorExists tcon = checkImportExists (flip UnknownImportDataConstructor tcon)    importNonHidden :: [DeclarationRef] -> Imports -> DeclarationRef -> m Imports@@ -160,55 +273,38 @@   importExplicit imp (PositionedDeclarationRef pos _ r) =     warnAndRethrowWithPosition pos $ importExplicit imp r   importExplicit imp (ValueRef name) = do-    values' <- updateImports (importedValues imp) showIdent (exportedValues exps) name+    let values' = updateImports (importedValues imp) (exportedValues exps) name     return $ imp { importedValues = values' }   importExplicit imp (TypeRef name dctors) = do-    types' <- updateImports (importedTypes imp) runProperName (first fst `map` exportedTypes exps) name-    let exportedDctors :: [(ProperName, ModuleName)]+    let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name+    let exportedDctors :: [(ProperName 'ConstructorName, ModuleName)]         exportedDctors = allExportedDataConstructors name-        dctorNames :: [ProperName]+        dctorNames :: [ProperName 'ConstructorName]         dctorNames = fst `map` exportedDctors     maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors     when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name-    dctors' <- foldM (\m -> updateImports m runProperName exportedDctors) (importedDataConstructors imp) (fromMaybe dctorNames dctors)+    let dctors' = foldl (\m -> updateImports m exportedDctors) (importedDataConstructors imp) (fromMaybe dctorNames dctors)     return $ imp { importedTypes = types', importedDataConstructors = dctors' }   importExplicit imp (TypeClassRef name) = do-    typeClasses' <- updateImports (importedTypeClasses imp) runProperName (exportedTypeClasses exps) name+    let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name     return $ imp { importedTypeClasses = typeClasses' }   importExplicit _ _ = internalError "Invalid argument to importExplicit"    -- Find all exported data constructors for a given type-  allExportedDataConstructors :: ProperName -> [(ProperName, ModuleName)]+  allExportedDataConstructors :: ProperName 'TypeName -> [(ProperName 'ConstructorName, ModuleName)]   allExportedDataConstructors name =     case find ((== name) . fst . fst) (exportedTypes exps) of       Nothing -> internalError "Invalid state in allExportedDataConstructors"       Just ((_, dctors), mn) -> map (, mn) dctors -  -- Add something to the Imports if it does not already exist there-  updateImports :: (Ord a) => M.Map (Qualified a) (Qualified a, ModuleName)-                              -> (a -> String)-                              -> [(a, ModuleName)]-                              -> a-                              -> m (M.Map (Qualified a) (Qualified a, ModuleName))-  updateImports imps' render exps' name = case M.lookup (Qualified impQual name) imps' of--    -- If the name is not already present add it to the list, after looking up-    -- where it was originally defined-    Nothing ->-      let mnOrig = fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps')-      in return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name, mnOrig) imps'--    -- If the name already is present check whether it's a duplicate import-    -- before rejecting it. For example, if module A defines X, and module B-    -- re-exports A, importing A and B in C should not result in a "conflicting-    -- import for `x`" error-    Just (Qualified (Just mn) _, mnOrig)-       | mnOrig == fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps') -> return imps'-       | otherwise -> throwError . errorMessage $ err-        where-        err = if currentModule `elem` [mn, importModule]-              then ConflictingImport (render name) importModule-              else ConflictingImports (render name) mn importModule--    Just (Qualified Nothing _, _) ->-      internalError "Invalid state in updateImports"+  -- Add something to an import resolution list+  updateImports+    :: (Ord a)+    => M.Map (Qualified a) [(Qualified a, ModuleName)]+    -> [(a, ModuleName)]+    -> a+    -> M.Map (Qualified a) [(Qualified a, ModuleName)]+  updateImports imps' exps' name =+    let mnOrig = fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps')+        currNames = fromMaybe [] (M.lookup (Qualified impQual name) imps')+    in M.insert (Qualified impQual name) ((Qualified (Just importModule) name, mnOrig) : currNames) imps'
src/Language/PureScript/Sugar/ObjectWildcards.hs view
@@ -1,17 +1,3 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Sugar.ObjectWildcards--- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess--- License     :  MIT (http://opensource.org/licenses/MIT)------ Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>--- Stability   :  experimental--- Portability :------ |---------------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -44,10 +30,10 @@   desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps   desugarExpr (ObjectUpdater (Just obj) ps) = wrapLambda (ObjectUpdate obj) ps   desugarExpr (ObjectUpdater Nothing ps) = do-    obj <- Ident <$> freshName+    obj <- freshIdent'     Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps   desugarExpr (ObjectGetter prop) = do-    arg <- Ident <$> freshName+    arg <- freshIdent'     return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg)))   desugarExpr e = return e @@ -63,5 +49,5 @@   mkProp :: (String, Maybe Expr) -> m (Maybe Ident, (String, Expr))   mkProp (name, Just e) = return (Nothing, (name, e))   mkProp (name, Nothing) = do-    arg <- Ident <$> freshName+    arg <- freshIdent'     return (Just arg, (name, Var (Qualified Nothing arg)))
src/Language/PureScript/Sugar/Operators.hs view
@@ -1,13 +1,9 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Sugar.Operators--- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess--- License     :  MIT (http://opensource.org/licenses/MIT)------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :---+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+ -- | -- This module implements the desugaring pass which reapplies binary operators based -- on their fixity data and removes explicit parentheses.@@ -15,13 +11,6 @@ -- The value parser ignores fixity data when parsing binary operator applications, so -- it is necessary to reorder them here. ----------------------------------------------------------------------------------{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards #-}- module Language.PureScript.Sugar.Operators (   rebracket,   removeSignedLiterals,@@ -44,6 +33,8 @@ import Data.Function (on) import Data.Functor.Identity import Data.List (groupBy, sortBy)+import Data.Maybe (mapMaybe, fromMaybe)+import qualified Data.Map as M  import qualified Text.Parsec as P import qualified Text.Parsec.Pos as P@@ -57,10 +48,24 @@ rebracket :: (Applicative m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module] rebracket externs ms = do   let fixities = concatMap externsFixities externs ++ concatMap collectFixities ms-  ensureNoDuplicates $ map (\(i, pos, _) -> (i, pos)) fixities-  let opTable = customOperatorTable $ map (\(i, _, f) -> (i, f)) fixities-  traverse (rebracketModule opTable) ms+  ensureNoDuplicates $ map (\(i, pos, _, _) -> (i, pos)) fixities+  let opTable = customOperatorTable $ map (\(i, _, f, _) -> (i, f)) fixities+  ms' <- traverse (rebracketModule opTable) ms+  let aliased = M.fromList (mapMaybe makeLookupEntry fixities)+  return $ renameAliasedOperators aliased `map` ms' +  where++  makeLookupEntry :: (Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident)) -> Maybe (Qualified Ident, Qualified Ident)+  makeLookupEntry (qname, _, _, alias) = (qname, ) <$> alias++  renameAliasedOperators :: M.Map (Qualified Ident) (Qualified Ident) -> Module -> Module+  renameAliasedOperators aliased (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts+    where+    (f', _, _) = everywhereOnValues id go id+    go (Var name) = Var $ fromMaybe name (name `M.lookup` aliased)+    go other = other+ removeSignedLiterals :: Module -> Module removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts   where@@ -82,17 +87,18 @@   go (Parens val) = val   go val = val -externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity)]+externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident))] externsFixities ExternsFile{..} =-  [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec)-  | ExternsFixity assoc prec op <- efFixities-  ]+   [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec, alias)+   | ExternsFixity assoc prec op alias <- efFixities+   ] -collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity)]+collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident))] collectFixities (Module _ _ moduleName ds _) = concatMap collect ds   where-  collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity)]-  collect (PositionedDeclaration pos _ (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]+  collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident))]+  collect (PositionedDeclaration pos _ (FixityDeclaration fixity name alias)) =+    [(Qualified (Just moduleName) (Op name), pos, fixity, alias)]   collect FixityDeclaration{} = internalError "Fixity without srcpos info"   collect _ = [] @@ -172,6 +178,6 @@   goExpr :: Expr -> m Expr   goExpr (OperatorSection op (Left val)) = return $ App op val   goExpr (OperatorSection op (Right val)) = do-    arg <- Ident <$> freshName+    arg <- freshIdent'     return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val   goExpr other = return other
src/Language/PureScript/Sugar/TypeClasses.hs view
@@ -1,22 +1,11 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Sugar.TypeClasses--- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess--- License     :  MIT (http://opensource.org/licenses/MIT)------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :---+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+ -- | -- This module implements the desugaring pass which creates type synonyms for type class dictionaries -- and dictionary expressions for type class instances. ----------------------------------------------------------------------------------{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RecordWildCards #-}- module Language.PureScript.Sugar.TypeClasses   ( desugarTypeClasses   , typeClassMemberName@@ -47,7 +36,7 @@  import qualified Data.Map as M -type MemberMap = M.Map (ModuleName, ProperName) ([(String, Maybe Kind)], [Constraint], [Declaration])+type MemberMap = M.Map (ModuleName, ProperName 'ClassName) ([(String, Maybe Kind)], [Constraint], [Declaration])  type Desugar = StateT MemberMap @@ -55,17 +44,27 @@ -- Add type synonym declarations for type class dictionary types, and value declarations for type class -- instance dictionary expressions. ---desugarTypeClasses :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]+desugarTypeClasses+  :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)+  => [ExternsFile]+  -> [Module]+  -> m [Module] desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModule   where   initialState :: MemberMap   initialState = M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations) -  fromExternsDecl :: ModuleName -> ExternsDeclaration -> Maybe ((ModuleName, ProperName), ([(String, Maybe Kind)], [Constraint], [Declaration]))+  fromExternsDecl+    :: ModuleName+    -> ExternsDeclaration+    -> Maybe ((ModuleName, ProperName 'ClassName), ([(String, Maybe Kind)], [Constraint], [Declaration]))   fromExternsDecl mn (EDClass name args members implies) = Just ((mn, name), (args, implies, map (uncurry TypeDeclaration) members))   fromExternsDecl _ _ = Nothing -desugarModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> Desugar m Module+desugarModule+  :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)+  => Module+  -> Desugar m Module desugarModule (Module ss coms name decls (Just exps)) = do   (newExpss, declss) <- unzip <$> parU (sortBy classesFirst decls) (desugarDecl name exps)   return $ Module ss coms name (concat declss) $ Just (exps ++ catMaybes newExpss)@@ -171,7 +170,12 @@ --       return new Sub(fooString, ""); --   }; -}-desugarDecl :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => ModuleName -> [DeclarationRef] -> Declaration -> Desugar m (Maybe DeclarationRef, [Declaration])+desugarDecl+  :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)+  => ModuleName+  -> [DeclarationRef]+  -> Declaration+  -> Desugar m (Maybe DeclarationRef, [Declaration]) desugarDecl mn exps = go   where   go d@(TypeClassDeclaration name args implies members) = do@@ -187,48 +191,60 @@     return (dr, map (PositionedDeclaration pos com) ds)   go other = return (Nothing, [other]) -  expRef :: Ident -> Qualified ProperName -> [Type] -> Maybe DeclarationRef+  expRef :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> Maybe DeclarationRef   expRef name className tys     | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef name     | otherwise = Nothing -  isExportedClass :: Qualified ProperName -> Bool+  isExportedClass :: Qualified (ProperName 'ClassName) -> Bool   isExportedClass = isExported (elem . TypeClassRef) -  isExportedType :: Qualified ProperName -> Bool+  isExportedType :: Qualified (ProperName 'TypeName) -> Bool   isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn) -  isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool+  isExported+    :: (ProperName a -> [DeclarationRef] -> Bool)+    -> Qualified (ProperName a)+    -> Bool   isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps   isExported _ _ = internalError "Names should have been qualified in name desugaring" -  matchesTypeRef :: ProperName -> DeclarationRef -> Bool+  matchesTypeRef :: ProperName 'TypeName -> DeclarationRef -> Bool   matchesTypeRef pn (TypeRef pn' _) = pn == pn'   matchesTypeRef _ _ = False -  getConstructors :: Type -> [Qualified ProperName]+  getConstructors :: Type -> [Qualified (ProperName 'TypeName)]   getConstructors = everythingOnTypes (++) getConstructor--  getConstructor :: Type -> [Qualified ProperName]-  getConstructor (TypeConstructor tcname) = [tcname]-  getConstructor _ = []+    where+    getConstructor (TypeConstructor tcname) = [tcname]+    getConstructor _ = []  memberToNameAndType :: Declaration -> (Ident, Type) memberToNameAndType (TypeDeclaration ident ty) = (ident, ty) memberToNameAndType (PositionedDeclaration _ _ d) = memberToNameAndType d memberToNameAndType _ = internalError "Invalid declaration in type class definition" -typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Declaration+typeClassDictionaryDeclaration+  :: ProperName 'ClassName+  -> [(String, Maybe Kind)]+  -> [Constraint]+  -> [Declaration]+  -> Declaration typeClassDictionaryDeclaration name args implies members =   let superclassTypes = superClassDictionaryNames implies `zip`-        [ function unit (foldl TypeApp (TypeConstructor superclass) tyArgs)+        [ function unit (foldl TypeApp (TypeConstructor (fmap coerceProperName superclass)) tyArgs)         | (superclass, tyArgs) <- implies         ]       members' = map (first runIdent . memberToNameAndType) members       mtys = members' ++ superclassTypes-  in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty))+  in TypeSynonymDeclaration (coerceProperName name) args (TypeApp tyObject $ rowFromList (mtys, REmpty)) -typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration+typeClassMemberToDictionaryAccessor+  :: ModuleName+  -> ProperName 'ClassName+  -> [(String, Maybe Kind)]+  -> Declaration+  -> Declaration typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =   let className = Qualified (Just mn) name   in ValueDeclaration ident Private [] $ Right $@@ -241,7 +257,16 @@ unit :: Type unit = TypeApp tyObject REmpty -typeInstanceDictionaryDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar m Declaration+typeInstanceDictionaryDeclaration+  :: forall m+   . (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)+  => Ident+  -> ModuleName+  -> [Constraint]+  -> Qualified (ProperName 'ClassName)+  -> [Type]+  -> [Declaration]+  -> Desugar m Declaration typeInstanceDictionaryDeclaration name mn deps className tys decls =   rethrow (addHint (ErrorInInstance className tys)) $ do   m <- get@@ -273,7 +298,7 @@             ]        let props = ObjectLiteral (members ++ superclasses)-          dictTy = foldl TypeApp (TypeConstructor className) tys+          dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys           constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)           dict = TypeClassDictionaryConstructorApp className props           result = ValueDeclaration name Private [] (Right (TypedValue True dict constrainedTy))@@ -287,7 +312,7 @@   declName (TypeDeclaration ident _) = Just ident   declName _ = Nothing -  memberToValue :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [(Ident, Type)] -> Declaration -> Desugar m Expr+  memberToValue :: [(Ident, Type)] -> Declaration -> Desugar m Expr   memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do     _ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident className) return $ lookup ident tys'     return val
src/Language/PureScript/Sugar/TypeClasses/Deriving.hs view
@@ -1,18 +1,3 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Sugar.TypeClasses.Deriving--- Copyright   :  (c) Gershom Bazerman 2015--- License     :  MIT (http://opensource.org/licenses/MIT)------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- This module implements the generic deriving elaboration that takes place during desugaring.---------------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}@@ -20,9 +5,10 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -module Language.PureScript.Sugar.TypeClasses.Deriving (-    deriveInstances-) where+-- |+-- This module implements the generic deriving elaboration that takes place during desugaring.+--+module Language.PureScript.Sugar.TypeClasses.Deriving (deriveInstances) where  import Prelude () import Prelude.Compat@@ -31,8 +17,9 @@ import Data.Maybe (fromMaybe) import Data.Ord (comparing) +import Control.Arrow (second) import Control.Monad (replicateM)-import Control.Monad.Supply.Class (MonadSupply, freshName)+import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.Error.Class (MonadError(..))  import Language.PureScript.Crash@@ -44,12 +31,20 @@ import qualified Language.PureScript.Constants as C  -- | Elaborates deriving instance declarations by code generation.-deriveInstances ::  (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m) => Module -> m Module+deriveInstances+  :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m)+  => Module+  -> m Module deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts  -- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration, -- elaborates that into an instance declaration via code generation.-deriveInstance :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration -> m Declaration+deriveInstance+  :: (Functor m, MonadError MultipleErrors m, MonadSupply m)+  => ModuleName+  -> [Declaration]+  -> Declaration+  -> m Declaration deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)   | className == Qualified (Just dataGeneric) (ProperName C.generic)   , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty@@ -60,12 +55,14 @@ deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d deriveInstance _  _  e = return e -unwrapTypeConstructor :: Type -> Maybe (Qualified ProperName, [Type])-unwrapTypeConstructor (TypeConstructor tyCon) = Just (tyCon, [])-unwrapTypeConstructor (TypeApp ty arg) = do-  (tyCon, args) <- unwrapTypeConstructor ty-  return (tyCon, arg : args)-unwrapTypeConstructor _ = Nothing+unwrapTypeConstructor :: Type -> Maybe (Qualified (ProperName 'TypeName), [Type])+unwrapTypeConstructor = fmap (second reverse) . go+  where+  go (TypeConstructor tyCon) = Just (tyCon, [])+  go (TypeApp ty arg) = do+    (tyCon, args) <- go ty+    return (tyCon, arg : args)+  go _ = Nothing  dataGeneric :: ModuleName dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]@@ -76,7 +73,13 @@ typesProxy :: ModuleName typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ] -deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> [Type] -> m [Declaration]+deriveGeneric+  :: (Functor m, MonadError MultipleErrors m, MonadSupply m)+  => ModuleName+  -> [Declaration]+  -> ProperName 'TypeName+  -> [Type]+  -> m [Declaration] deriveGeneric mn ds tyConNm args = do   tyCon <- findTypeDecl tyConNm ds   toSpine <- mkSpineFunction mn tyCon@@ -87,7 +90,11 @@          , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)          ] -findTypeDecl :: (Functor m, MonadError MultipleErrors m) => ProperName -> [Declaration] -> m Declaration+findTypeDecl+  :: (Functor m, MonadError MultipleErrors m)+  => ProperName 'TypeName+  -> [Declaration]+  -> m Declaration findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType tyConNm) return . find isTypeDecl   where   isTypeDecl :: Declaration -> Bool@@ -104,9 +111,9 @@   recordConstructor :: Expr -> Expr   recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord"))) -  mkCtorClause :: (ProperName, [Type]) -> m CaseAlternative+  mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative   mkCtorClause (ctorName, tys) = do-    idents <- replicateM (length tys) (fmap Ident freshName)+    idents <- replicateM (length tys) freshIdent'     return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))     where     caseResult idents =@@ -137,10 +144,12 @@   proxy :: Type -> Type   proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy"))) -  mkProdClause :: (ProperName, [Type]) -> Expr-  mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))-                                               , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)-                                               ]+  mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr+  mkProdClause (ctorName, tys) =+    ObjectLiteral+      [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))+      , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)+      ]    mkProductSignature :: Type -> Expr   mkProductSignature r | Just rec <- objectType r =@@ -170,9 +179,9 @@   recordBinder :: [Binder] -> Binder   recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord")) -  mkAlternative :: (ProperName, [Type]) -> m CaseAlternative+  mkAlternative :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative   mkAlternative (ctorName, tys) = do-    idents <- replicateM (length tys) (fmap Ident freshName)+    idents <- replicateM (length tys) freshIdent'     return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]]                . Right                $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))
src/Language/PureScript/TypeChecker.hs view
@@ -1,22 +1,10 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.TypeChecker--- Copyright   :  (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess--- License     :  MIT (http://opensource.org/licenses/MIT)------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- The top-level type checker, which checks all declarations in a module.---------------------------------------------------------------------------------- {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} +-- |+-- The top-level type checker, which checks all declarations in a module.+-- module Language.PureScript.TypeChecker (     module T,     typeCheckModule@@ -37,6 +25,7 @@ import qualified Data.Map as M  import Control.Monad (when, unless, void, forM, forM_)+import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.State.Class (MonadState(..), modify) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(..))@@ -50,15 +39,15 @@ import Language.PureScript.Environment import Language.PureScript.Errors -addDataType ::-  (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>-  ModuleName ->-  DataDeclType ->-  ProperName ->-  [(String, Maybe Kind)] ->-  [(ProperName, [Type])] ->-  Kind ->-  m ()+addDataType+  :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)+  => ModuleName+  -> DataDeclType+  -> ProperName 'TypeName+  -> [(String, Maybe Kind)]+  -> [(ProperName 'ConstructorName, [Type])]+  -> Kind+  -> m () addDataType moduleName dtype name args dctors ctorKind = do   env <- getEnv   putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }@@ -66,15 +55,15 @@     warnAndRethrow (addHint (ErrorInDataConstructor dctor)) $       addDataConstructor moduleName dtype name (map fst args) dctor tys -addDataConstructor ::-  (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>-  ModuleName ->-  DataDeclType ->-  ProperName ->-  [String] ->-  ProperName ->-  [Type] ->-  m ()+addDataConstructor+  :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)+  => ModuleName+  -> DataDeclType+  -> ProperName 'TypeName+  -> [String]+  -> ProperName 'ConstructorName+  -> [Type]+  -> m () addDataConstructor moduleName dtype name args dctor tys = do   env <- getEnv   traverse_ checkTypeSynonyms tys@@ -84,50 +73,50 @@   let fields = [Ident ("value" ++ show n) | n <- [0..(length tys - 1)]]   putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) } -addTypeSynonym ::-  (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>-  ModuleName ->-  ProperName ->-  [(String, Maybe Kind)] ->-  Type ->-  Kind ->-  m ()+addTypeSynonym+  :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)+  => ModuleName+  -> ProperName 'TypeName+  -> [(String, Maybe Kind)]+  -> Type+  -> Kind+  -> m () addTypeSynonym moduleName name args ty kind = do   env <- getEnv   checkTypeSynonyms ty   putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env)                , typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) } -valueIsNotDefined ::-  (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>-  ModuleName ->-  Ident ->-  m ()+valueIsNotDefined+  :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)+  => ModuleName+  -> Ident+  -> m () valueIsNotDefined moduleName name = do   env <- getEnv   case M.lookup (moduleName, name) (names env) of     Just _ -> throwError . errorMessage $ RedefinedIdent name     Nothing -> return () -addValue ::-  (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>-  ModuleName ->-  Ident ->-  Type ->-  NameKind ->-  m ()+addValue+  :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)+  => ModuleName+  -> Ident+  -> Type+  -> NameKind+  -> m () addValue moduleName name ty nameKind = do   env <- getEnv   putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) }) -addTypeClass ::-  (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>-  ModuleName ->-  ProperName ->-  [(String, Maybe Kind)] ->-  [Constraint] ->-  [Declaration] ->-  m ()+addTypeClass+  :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)+  => ModuleName+  -> ProperName 'ClassName+  -> [(String, Maybe Kind)]+  -> [Constraint]+  -> [Declaration]+  -> m () addTypeClass moduleName pn args implies ds =   let members = map toPair ds in   modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }@@ -136,30 +125,30 @@   toPair (PositionedDeclaration _ _ d) = toPair d   toPair _ = internalError "Invalid declaration in TypeClassDeclaration" -addTypeClassDictionaries ::-  (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>-  Maybe ModuleName ->-  M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope) ->-  m ()+addTypeClassDictionaries+  :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)+  => Maybe ModuleName+  -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)+  -> m () addTypeClassDictionaries mn entries =   modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = insertState st } }   where insertState st = M.insertWith (M.unionWith M.union) mn entries (typeClassDictionaries . checkEnv $ st) -checkDuplicateTypeArguments ::-  (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>-  [String] ->-  m ()+checkDuplicateTypeArguments+  :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)+  => [String]+  -> m () checkDuplicateTypeArguments args = for_ firstDup $ \dup ->   throwError . errorMessage $ DuplicateTypeArgument dup   where   firstDup :: Maybe String   firstDup = listToMaybe $ args \\ nub args -checkTypeClassInstance ::-  (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>-  ModuleName ->-  Type ->-  m ()+checkTypeClassInstance+  :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)+  => ModuleName+  -> Type+  -> m () checkTypeClassInstance _ (TypeVar _) = return () checkTypeClassInstance _ (TypeConstructor ctor) = do   env <- getEnv@@ -171,10 +160,10 @@ -- | -- Check that type synonyms are fully-applied in a type ---checkTypeSynonyms ::-  (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>-  Type ->-  m ()+checkTypeSynonyms+  :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)+  => Type+  -> m () checkTypeSynonyms = void . replaceAllTypeSynonyms  -- |@@ -190,13 +179,14 @@ -- --  * Process module imports ---typeCheckAll :: forall m.-  (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>-  ModuleName ->-  [DeclarationRef] ->-  [Declaration] ->-  m [Declaration]-typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkOrphanFixities ds+typeCheckAll+  :: forall m+   . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)+  => ModuleName+  -> [DeclarationRef]+  -> [Declaration]+  -> m [Declaration]+typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds   where   go :: Declaration -> m Declaration   go (DataDeclaration dtype name args dctors) = do@@ -208,7 +198,7 @@       addDataType moduleName dtype name args' dctors ctorKind     return $ DataDeclaration dtype name args dctors     where-    checkNewtype :: [(ProperName, [Type])] -> m ()+    checkNewtype :: [(ProperName 'ConstructorName, [Type])] -> m ()     checkNewtype [(_, [_])] = return ()     checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype name     checkNewtype _ = throwError . errorMessage $ InvalidNewtype name@@ -290,13 +280,16 @@   go (PositionedDeclaration pos com d) =     warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d -  checkOrphanFixities :: Declaration -> m ()-  checkOrphanFixities (FixityDeclaration _ name) = do+  checkFixities :: Declaration -> m ()+  checkFixities (FixityDeclaration _ name (Just alias)) = do+    ty <- lookupVariable moduleName alias+    addValue moduleName (Op name) ty Public+  checkFixities (FixityDeclaration _ name _) = do     env <- getEnv     guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env-  checkOrphanFixities (PositionedDeclaration pos _ d) =-    warnAndRethrowWithPosition pos $ checkOrphanFixities d-  checkOrphanFixities _ = return ()+  checkFixities (PositionedDeclaration pos _ d) =+    warnAndRethrowWithPosition pos $ checkFixities d+  checkFixities _ = return ()    checkInstanceMembers :: [Declaration] -> m [Declaration]   checkInstanceMembers instDecls = do@@ -316,7 +309,7 @@       | otherwise = firstDuplicate xs     firstDuplicate _ = Nothing -  checkOrphanInstance :: Ident -> Qualified ProperName -> [Type] -> m ()+  checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> m ()   checkOrphanInstance dictName className@(Qualified (Just mn') _) tys'     | moduleName == mn' || any checkType tys' = return ()     | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'@@ -343,10 +336,11 @@ -- Type check an entire module and ensure all types and classes defined within the module that are -- required by exported members are also exported. ---typeCheckModule :: forall m.-  (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>-  Module ->-  m Module+typeCheckModule+  :: forall m+   . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)+  => Module+  -> m Module typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated" typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do   modify (\s -> s { checkCurrentModule = Just mn })@@ -355,6 +349,7 @@     checkTypesAreExported e     checkClassMembersAreExported e     checkClassesAreExported e+    checkNonAliasesAreExported e   return $ Module ss coms mn decls' (Just exps)   where @@ -410,7 +405,7 @@       where       go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . fst) cs       go _ = []-    extractCurrentModuleClass :: Qualified ProperName -> Maybe ProperName+    extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> Maybe (ProperName 'ClassName)     extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name     extractCurrentModuleClass _ = Nothing @@ -429,3 +424,18 @@     extractMemberName (TypeDeclaration memberName _) = memberName     extractMemberName _ = internalError "Unexpected declaration in typeclass member list"   checkClassMembersAreExported _ = return ()++  checkNonAliasesAreExported :: DeclarationRef -> m ()+  checkNonAliasesAreExported dr@(ValueRef (Op name)) =+    case listToMaybe (mapMaybe getAlias decls) of+      Just alias ->+        when (not $ any (== ValueRef alias) exps) $+          throwError . errorMessage $ TransitiveExportError dr [ValueRef alias]+      _ -> return ()+    where+    getAlias :: Declaration -> Maybe Ident+    getAlias (PositionedDeclaration _ _ d) = getAlias d+    getAlias (FixityDeclaration _ name' (Just (Qualified (Just mn') alias)))+      | mn == mn' && name == name' = Just alias+    getAlias _ = Nothing+  checkNonAliasesAreExported _ = return ()
src/Language/PureScript/TypeChecker/Entailment.hs view
@@ -1,24 +1,10 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.TypeChecker.Entailment--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- Type class entailment---------------------------------------------------------------------------------- {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} -module Language.PureScript.TypeChecker.Entailment (-    entails-) where+-- |+-- Type class entailment+--+module Language.PureScript.TypeChecker.Entailment (entails) where  import Prelude () import Prelude.Compat@@ -46,15 +32,16 @@ -- 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.-  (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>-  ModuleName ->-  M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) ->-  Constraint ->-  m Expr+entails+  :: forall m+   . (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)+  => ModuleName+  -> M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))+  -> Constraint+  -> m Expr entails moduleName context = solve   where-    forClassName :: Qualified ProperName -> [Type] -> [TypeClassDictionaryInScope]+    forClassName :: Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]     forClassName cn@(Qualified (Just mn) _) tys = concatMap (findDicts cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))     forClassName _ _ = internalError "forClassName: expected qualified class name" @@ -64,7 +51,7 @@     ctorModules (TypeApp ty _) = ctorModules ty     ctorModules _ = Nothing -    findDicts :: Qualified ProperName -> Maybe ModuleName -> [TypeClassDictionaryInScope]+    findDicts :: Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope]     findDicts cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup context      solve :: Constraint -> m Expr@@ -72,7 +59,7 @@       dict <- go 0 className tys       return $ dictionaryValueToValue dict       where-      go :: Int -> Qualified ProperName -> [Type] -> m DictionaryValue+      go :: Int -> Qualified (ProperName 'ClassName) -> [Type] -> m DictionaryValue       go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'       go work className' tys' = do         let instances = do@@ -147,7 +134,7 @@ -- and return a substitution from type variables to types which makes the type heads unify. -- typeHeadsAreEqual :: ModuleName -> Type -> Type -> Maybe [(String, Type)]-typeHeadsAreEqual _ (Skolem _ s1 _)      (Skolem _ s2 _)      | s1 == s2 = Just []+typeHeadsAreEqual _ (Skolem _ s1 _ _)    (Skolem _ s2 _ _)    | s1 == s2 = Just [] typeHeadsAreEqual _ t                    (TypeVar v)                     = Just [(v, t)] typeHeadsAreEqual _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just [] typeHeadsAreEqual m (TypeApp h1 t1)      (TypeApp h2 t2)                 = (++) <$> typeHeadsAreEqual m h1 h2@@ -164,12 +151,12 @@           <*> go sd1 r1' sd2 r2'   where   go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Maybe [(String, Type)]-  go [] REmpty          [] REmpty          = Just []-  go [] (TUnknown _)    _  _               = Just []-  go [] (TypeVar v1)    [] (TypeVar v2)    | v1 == v2 = Just []-  go [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = Just []-  go sd r               [] (TypeVar v)     = Just [(v, rowFromList (sd, r))]-  go _  _               _  _               = Nothing+  go [] REmpty            [] REmpty            = Just []+  go [] (TUnknown _)      _  _                 = Just []+  go [] (TypeVar v1)      [] (TypeVar v2)      | v1 == v2 = Just []+  go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) | s1 == s2 = Just []+  go sd r                 [] (TypeVar v)       = Just [(v, rowFromList (sd, r))]+  go _  _                 _  _                 = Nothing typeHeadsAreEqual _ _ _ = Nothing  -- |
src/Language/PureScript/TypeChecker/Kinds.hs view
@@ -1,18 +1,3 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.TypeChecker.Kinds--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- This module implements the kind checker---------------------------------------------------------------------------------- {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}@@ -20,12 +5,15 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} -module Language.PureScript.TypeChecker.Kinds (-    kindOf,-    kindOfWithScopedVars,-    kindsOf,-    kindsOfAll-) where+-- |+-- This module implements the kind checker+--+module Language.PureScript.TypeChecker.Kinds+  ( kindOf+  , kindOfWithScopedVars+  , kindsOf+  , kindsOfAll+  ) where  import Prelude () import Prelude.Compat@@ -54,7 +42,11 @@   return $ KUnknown k  -- | Update the substitution to solve a kind constraint-solveKind :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Int -> Kind -> m ()+solveKind+  :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)+  => Int+  -> Kind+  -> m () solveKind u k = do   occursCheck u k   modify $ \cs -> cs { checkSubstitution =@@ -75,7 +67,11 @@   go other = other  -- | Make sure that an unknown does not occur in a kind-occursCheck :: (Functor m, Applicative m, MonadError MultipleErrors m) => Int -> Kind -> m ()+occursCheck+  :: (Functor m, Applicative m, MonadError MultipleErrors m)+  => Int+  -> Kind+  -> m () occursCheck _ KUnknown{} = return () occursCheck u k = void $ everywhereOnKindsM go k   where@@ -83,7 +79,11 @@   go other = return other  -- | Unify two kinds-unifyKinds :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Kind -> Kind -> m ()+unifyKinds+  :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)+  => Kind+  -> Kind+  -> m () unifyKinds k1 k2 = do   sub <- gets checkSubstitution   go (substituteKind sub k1) (substituteKind sub k2)@@ -100,10 +100,10 @@   go k1' k2' = throwError . errorMessage $ KindsDoNotUnify k1' k2'  -- | Infer the kind of a single type-kindOf ::-  (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>-  Type ->-  m Kind+kindOf+  :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)+  => Type+  -> m Kind kindOf ty = fst <$> kindOfWithScopedVars ty  -- | Infer the kind of a single type, returning the kinds of any scoped type variables@@ -120,14 +120,14 @@                             )  -- | Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors-kindsOf ::-  (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>-  Bool ->-  ModuleName ->-  ProperName ->-  [(String, Maybe Kind)] ->-  [Type] ->-  m Kind+kindsOf+  :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)+  => Bool+  -> ModuleName+  -> ProperName 'TypeName+  -> [(String, Maybe Kind)]+  -> [Type]+  -> m Kind kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do   tyCon <- freshKind   kargs <- replicateM (length args) freshKind@@ -138,23 +138,23 @@   where   tidyUp (k, sub) = starIfUnknown $ substituteKind sub k -freshKindVar ::-  (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) =>-  (String, Maybe Kind) ->-  Kind ->-  m (ProperName, Kind)+freshKindVar+  :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)+  => (String, Maybe Kind)+  -> Kind+  -> m (ProperName 'TypeName, Kind) freshKindVar (arg, Nothing) kind = return (ProperName arg, kind) freshKindVar (arg, Just kind') kind = do   unifyKinds kind kind'   return (ProperName arg, kind')  -- | Simultaneously infer the kinds of several mutually recursive type constructors-kindsOfAll ::-  (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>-  ModuleName ->-  [(ProperName, [(String, Maybe Kind)], Type)] ->-  [(ProperName, [(String, Maybe Kind)], [Type])] ->-  m ([Kind], [Kind])+kindsOfAll+  :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)+  => ModuleName+  -> [(ProperName 'TypeName, [(String, Maybe Kind)], Type)]+  -> [(ProperName 'TypeName, [(String, Maybe Kind)], [Type])]+  -> m ([Kind], [Kind]) kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do   synVars <- replicateM (length syns) freshKind   let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars@@ -177,7 +177,13 @@   tidyUp ((ks1, ks2), sub) = (map (starIfUnknown . substituteKind sub) ks1, map (starIfUnknown . substituteKind sub) ks2)  -- | Solve the set of kind constraints associated with the data constructors for a type constructor-solveTypes :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Bool -> [Type] -> [Kind] -> Kind -> m Kind+solveTypes+  :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)+  => Bool+  -> [Type]+  -> [Kind]+  -> Kind+  -> m Kind solveTypes isData ts kargs tyCon = do   ks <- traverse (fmap fst . infer) ts   when isData $ do@@ -195,10 +201,17 @@ starIfUnknown k = k  -- | Infer a kind for a type-infer :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> m (Kind, [(String, Kind)])+infer+  :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)+  => Type+  -> m (Kind, [(String, Kind)]) infer ty = rethrow (addHint (ErrorCheckingKind ty)) $ infer' ty -infer' :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> m (Kind, [(String, Kind)])+infer'+  :: forall m+   . (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)+  => Type+  -> m (Kind, [(String, Kind)]) infer' (ForAll ident ty _) = do   k1 <- freshKind   Just moduleName <- checkCurrentModule <$> get@@ -226,7 +239,7 @@   go (TypeVar v) = do     Just moduleName <- checkCurrentModule <$> get     lookupTypeVariable moduleName (Qualified Nothing (ProperName v))-  go (Skolem v _ _) = do+  go (Skolem v _ _ _) = do     Just moduleName <- checkCurrentModule <$> get     lookupTypeVariable moduleName (Qualified Nothing (ProperName v))   go (TypeConstructor v) = do@@ -250,7 +263,7 @@     return $ Row k1   go (ConstrainedType deps ty) = do     forM_ deps $ \(className, tys) -> do-      k <- go $ foldl TypeApp (TypeConstructor className) tys+      k <- go $ foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys       unifyKinds k Star     k <- go ty     unifyKinds k Star
src/Language/PureScript/TypeChecker/Monad.hs view
@@ -1,18 +1,3 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.TypeChecker.Monad--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- Monads for type checking and type inference and associated data types---------------------------------------------------------------------------------- {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-}@@ -20,6 +5,9 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +-- |+-- Monads for type checking and type inference and associated data types+-- module Language.PureScript.TypeChecker.Monad where  import Prelude ()@@ -57,20 +45,23 @@   , checkNextKind :: Int                    -- ^ The next kind unification variable   , checkNextSkolem :: Int                  -- ^ The next skolem variable   , checkNextSkolemScope :: Int             -- ^ The next skolem scope constant-  , checkNextDictName :: Int                -- ^ The next type class dictionary name   , checkCurrentModule :: Maybe ModuleName  -- ^ The current module   , checkSubstitution :: Substitution       -- ^ The current substitution   }  -- | Create an empty @CheckState@ emptyCheckState :: Environment -> CheckState-emptyCheckState env = CheckState env 0 0 0 0 0 Nothing emptySubstitution+emptyCheckState env = CheckState env 0 0 0 0 Nothing emptySubstitution  -- | Unification variables type Unknown = Int  -- | Temporarily bind a collection of names to values-bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> m a -> m a+bindNames+  :: MonadState CheckState m+  => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)+  -> m a+  -> m a bindNames newNames action = do   orig <- get   modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }@@ -79,7 +70,11 @@   return a  -- | Temporarily bind a collection of names to types-bindTypes :: (MonadState CheckState m) => M.Map (Qualified ProperName) (Kind, TypeKind) -> m a -> m a+bindTypes+  :: MonadState CheckState m+  => M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)+  -> m a+  -> m a bindTypes newNames action = do   orig <- get   modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }@@ -88,7 +83,12 @@   return a  -- | Temporarily bind a collection of names to types-withScopedTypeVars :: (Functor m, Applicative m, MonadState CheckState m, MonadWriter MultipleErrors m) => ModuleName -> [(String, Kind)] -> m a -> m a+withScopedTypeVars+  :: (Functor m, Applicative m, MonadState CheckState m, MonadWriter MultipleErrors m)+  => ModuleName+  -> [(String, Kind)]+  -> m a+  -> m a withScopedTypeVars mn ks ma = do   orig <- get   forM_ ks $ \(name, _) ->@@ -97,7 +97,11 @@   bindTypes (M.fromList (map (\(name, k) -> (Qualified (Just mn) (ProperName name), (k, ScopedTypeVar))) ks)) ma  -- | Temporarily make a collection of type class dictionaries available-withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a+withTypeClassDictionaries+  :: MonadState CheckState m+  => [TypeClassDictionaryInScope]+  -> m a+  -> m a withTypeClassDictionaries entries action = do   orig <- get   let mentries = M.fromListWith (M.unionWith M.union) [ (mn, M.singleton className (M.singleton (tcdName entry) entry)) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _, tcdClassName = className }  <- entries ]@@ -107,25 +111,35 @@   return a  -- | Get the currently available map of type class dictionaries-getTypeClassDictionaries ::-  (Functor m, MonadState CheckState m) =>-  m (M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))+getTypeClassDictionaries+  :: (Functor m, MonadState CheckState m)+  => m (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))) getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get  -- | Lookup type class dictionaries in a module.-lookupTypeClassDictionaries ::-  (Functor m, MonadState CheckState m) =>-  Maybe ModuleName ->-  m (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope))+lookupTypeClassDictionaries+  :: (Functor m, MonadState CheckState m)+  => Maybe ModuleName+  -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get  -- | Temporarily bind a collection of names to local variables-bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type, NameVisibility)] -> m a -> m a+bindLocalVariables+  :: (Functor m, MonadState CheckState m)+  => ModuleName+  -> [(Ident, Type, NameVisibility)]+  -> m a+  -> m a bindLocalVariables moduleName bindings =   bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> ((moduleName, name), (ty, Private, visibility)))  -- | Temporarily bind a collection of names to local type variables-bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a+bindLocalTypeVariables+  :: (Functor m, MonadState CheckState m)+  => ModuleName+  -> [(ProperName 'TypeName, Kind)]+  -> m a+  -> m a bindLocalTypeVariables moduleName bindings =   bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (Just moduleName) pn, (kind, LocalTypeVariable))) @@ -146,7 +160,11 @@   return a  -- | Lookup the type of a value by name in the @Environment@-lookupVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type+lookupVariable+  :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)+  => ModuleName+  -> Qualified Ident+  -> m Type lookupVariable currentModule (Qualified moduleName var) = do   env <- getEnv   case M.lookup (fromMaybe currentModule moduleName, var) (names env) of@@ -154,7 +172,11 @@     Just (ty, _, _) -> return ty  -- | Lookup the visibility of a value by name in the @Environment@-getVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility+getVisibility+  :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)+  => ModuleName+  -> Qualified Ident+  -> m NameVisibility getVisibility currentModule (Qualified moduleName var) = do   env <- getEnv   case M.lookup (fromMaybe currentModule moduleName, var) (names env) of@@ -162,7 +184,11 @@     Just (_, _, vis) -> return vis  -- | Assert that a name is visible-checkVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m ()+checkVisibility+  :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)+  => ModuleName+  -> Qualified Ident+  -> m () checkVisibility currentModule name@(Qualified _ var) = do   vis <- getVisibility currentModule name   case vis of@@ -170,7 +196,11 @@     _ -> return ()  -- | Lookup the kind of a type by name in the @Environment@-lookupTypeVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind+lookupTypeVariable+  :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)+  => ModuleName+  -> Qualified (ProperName 'TypeName)+  -> m Kind lookupTypeVariable currentModule (Qualified moduleName name) = do   env <- getEnv   case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of@@ -201,13 +231,6 @@ guardWith :: (MonadError e m) => e -> Bool -> m () guardWith _ True = return () guardWith e False = throwError e---- | Generate new type class dictionary name-freshDictionaryName :: (Functor m, MonadState CheckState m) => m Int-freshDictionaryName = do-  n <- checkNextDictName <$> get-  modify $ \s -> s { checkNextDictName = succ (checkNextDictName s) }-  return n  -- | Run a computation in the substitution monad, generating a return value and the final substitution. liftUnify ::
src/Language/PureScript/TypeChecker/Skolems.hs view
@@ -71,30 +71,30 @@ -- | -- Skolemize a type variable by replacing its instances with fresh skolem constants ---skolemize :: String -> Int -> SkolemScope -> Type -> Type-skolemize ident sko scope = replaceTypeVars ident (Skolem ident sko scope)+skolemize :: String -> Int -> SkolemScope -> Maybe SourceSpan -> Type -> Type+skolemize ident sko scope ss = replaceTypeVars ident (Skolem ident sko scope ss)  -- | -- This function has one purpose - to skolemize type variables appearing in a -- SuperClassDictionary placeholder. These type variables are somewhat unique since they are the -- only example of scoped type variables. ---skolemizeTypesInValue :: String -> Int -> SkolemScope -> Expr -> Expr-skolemizeTypesInValue ident sko scope =+skolemizeTypesInValue :: String -> Int -> SkolemScope -> Maybe SourceSpan -> Expr -> Expr+skolemizeTypesInValue ident sko scope ss =   let     (_, f, _, _, _) = everywhereWithContextOnValuesM [] defS onExpr onBinder defS defS   in runIdentity . f   where   onExpr :: [String] -> Expr -> Identity ([String], Expr)   onExpr sco (SuperClassDictionary c ts)-    | ident `notElem` sco = return (sco, SuperClassDictionary c (map (skolemize ident sko scope) ts))+    | ident `notElem` sco = return (sco, SuperClassDictionary c (map (skolemize ident sko scope ss) ts))   onExpr sco (TypedValue check val ty)-    | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ty))+    | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ss ty))   onExpr sco other = return (sco, other)    onBinder :: [String] -> Binder -> Identity ([String], Binder)   onBinder sco (TypedBinder ty b)-    | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedBinder (skolemize ident sko scope ty) b)+    | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedBinder (skolemize ident sko scope ss ty) b)   onBinder sco other = return (sco, other)    peelTypeVars :: Type -> [String]@@ -129,7 +129,7 @@     collectSkolems :: Type -> [SkolemScope]     collectSkolems = nub . everythingOnTypes (++) collect       where-      collect (Skolem _ _ scope) = [scope]+      collect (Skolem _ _ scope _) = [scope]       collect _ = []   go scos _ = (scos, [])   findBindingScope :: SkolemScope -> Maybe Expr
src/Language/PureScript/TypeChecker/Subsumption.hs view
@@ -55,7 +55,7 @@   case sco of     Just sco' -> do       sko <- newSkolemConstant-      let sk = skolemize ident sko sco' ty2+      let sk = skolemize ident sko sco' Nothing ty2       subsumes val 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
src/Language/PureScript/TypeChecker/Types.hs view
@@ -1,23 +1,11 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.TypeChecker.Types--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- This module implements the type checker---------------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +-- |+-- This module implements the type checker+-- module Language.PureScript.TypeChecker.Types (     typesOf ) where@@ -48,6 +36,7 @@  import Control.Monad import Control.Monad.State.Class (MonadState(..), gets)+import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(..)) @@ -72,7 +61,7 @@ -- | Infer the types of multiple mutually-recursive values, and return elaborated values including -- type class dictionaries and type annotations. typesOf ::-  (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>+  (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>   ModuleName ->   [(Ident, Expr)] ->   m [(Ident, (Expr, Type))]@@ -129,7 +118,7 @@   return (untyped, typed, dict, untypedDict)  checkTypedBindingGroupElement ::-  (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>+  (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>   ModuleName ->   (Ident, (Expr, Type, Bool)) ->   TypeData ->@@ -148,7 +137,7 @@   return (ident, (val'', ty''))  typeForBindingGroupElement ::-  (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>+  (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>   Bool ->   (Ident, Expr) ->   TypeData ->@@ -213,20 +202,19 @@   instantiatePolyTypeWithUnknowns val ty' instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do    dicts <- getTypeClassDictionaries-   (_, ty') <- instantiatePolyTypeWithUnknowns (internalError "Types under a constraint cannot themselves be constrained") ty-   return (foldl App val (map (flip TypeClassDictionary dicts) constraints), ty')+   instantiatePolyTypeWithUnknowns (foldl App val (map (flip TypeClassDictionary dicts) constraints)) ty instantiatePolyTypeWithUnknowns val ty = return (val, ty)  -- | Infer a type for a value, rethrowing any error to provide a more useful error message infer ::-  (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>+  (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>   Expr ->   m Expr infer val = rethrow (addHint (ErrorInferringType val)) $ infer' val  -- | Infer a type for a value infer' ::-  (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>+  (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>   Expr ->   m Expr infer' v@(NumericLiteral (Left _)) = return $ TypedValue True v tyInt@@ -313,7 +301,7 @@ infer' _ = internalError "Invalid argument to infer"  inferLetBinding ::-  (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>+  (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>   [Declaration] ->   [Declaration] ->   Expr ->@@ -407,9 +395,9 @@ -- change the definition of `binderRequiresMonotype`, -- and use `kindOfWithScopedVars`. inferBinder val (TypedBinder ty binder) = do+  kind <- kindOf ty+  checkTypeKind ty kind   ty1 <- replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty-  kind <- kindOf ty1-  checkTypeKind ty1 kind   unifyTypes val ty1   inferBinder val binder @@ -424,7 +412,7 @@  -- | Instantiate polytypes only when necessitated by a binder. instantiateForBinders ::-  (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>+  (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>   [Expr] ->   [CaseAlternative] ->   m ([Expr], [Type])@@ -441,7 +429,7 @@ -- Check the types of the return values in a set of binders in a case statement -- checkBinders ::-  (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>+  (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>   [Type] ->   Type ->   [CaseAlternative] ->@@ -471,7 +459,7 @@ -- Check the type of a value, rethrowing errors to provide a better error message -- check ::-  (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>+  (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>   Expr ->   Type ->   m Expr@@ -480,29 +468,36 @@ -- | -- Check the type of a value ---check' :: forall m.-  (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>-  Expr ->-  Type ->-  m Expr+check'+  :: forall m+   . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)+  => Expr+  -> Type+  -> m Expr check' val (ForAll ident ty _) = do   scope <- newSkolemScope   sko <- newSkolemConstant-  let sk = skolemize ident sko scope ty-  let skVal = skolemizeTypesInValue ident sko scope val+  let ss = case val of+             PositionedValue pos _ _ -> Just pos+             _ -> Nothing+      sk = skolemize ident sko scope ss ty+      skVal = skolemizeTypesInValue ident sko scope ss val   val' <- check skVal sk   return $ TypedValue True val' (ForAll ident ty (Just scope)) check' val t@(ConstrainedType constraints ty) = do-  dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do-    n <- freshDictionaryName-    return $ Ident $ "__dict_" ++ className ++ "_" ++ show n+  dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) ->+    freshIdent ("dict" ++ className)   dicts <- join <$> zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints   val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty   return $ TypedValue True (foldr (Abs . Left) val' dictNames) t   where   -- | Add a dictionary for the constraint to the scope, and dictionaries   -- for all implied superclass instances.-  newDictionaries :: [(Qualified ProperName, Integer)] -> Qualified Ident -> (Qualified ProperName, [Type]) -> m [TypeClassDictionaryInScope]+  newDictionaries+    :: [(Qualified (ProperName 'ClassName), Integer)]+    -> Qualified Ident+    -> (Qualified (ProperName 'ClassName), [Type])+    -> m [TypeClassDictionaryInScope]   newDictionaries path name (className, instanceTy) = do     tcs <- gets (typeClasses . checkEnv)     let (args, _, superclasses) = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs@@ -637,7 +632,7 @@ -- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case. -- checkProperties ::-  (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>+  (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>   Expr ->   [(String, Expr)] ->   Type ->@@ -669,7 +664,7 @@  -- | Check the type of a function application, rethrowing errors to provide a better error message checkFunctionApplication ::-  (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>+  (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>   Expr ->   Type ->   Expr ->@@ -681,7 +676,7 @@  -- | Check the type of a function application checkFunctionApplication' ::-  (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>+  (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>   Expr ->   Type ->   Expr ->
src/Language/PureScript/TypeChecker/Unify.hs view
@@ -105,13 +105,13 @@     case (sc1, sc2) of       (Just sc1', Just sc2') -> do         sko <- newSkolemConstant-        let sk1 = skolemize ident1 sko sc1' ty1-        let sk2 = skolemize ident2 sko sc2' ty2+        let sk1 = skolemize ident1 sko sc1' Nothing ty1+        let sk2 = skolemize ident2 sko sc2' Nothing ty2         sk1 `unifyTypes` sk2       _ -> internalError "unifyTypes: unspecified skolem scope"   unifyTypes' (ForAll ident ty1 (Just sc)) ty2 = do     sko <- newSkolemConstant-    let sk = skolemize ident sko sc ty1+    let sk = skolemize ident sko sc Nothing ty1     sk `unifyTypes` ty2   unifyTypes' ForAll{} _ = internalError "unifyTypes: unspecified skolem scope"   unifyTypes' ty f@ForAll{} = f `unifyTypes` ty@@ -121,7 +121,7 @@   unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do     t3 `unifyTypes` t5     t4 `unifyTypes` t6-  unifyTypes' (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = return ()+  unifyTypes' (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = return ()   unifyTypes' (KindedType ty1 _) ty2 = ty1 `unifyTypes` ty2   unifyTypes' ty1 (KindedType ty2 _) = ty1 `unifyTypes` ty2   unifyTypes' r1@RCons{} r2 = unifyRows r1 r2@@ -162,15 +162,15 @@     solveType u2 (rowFromList (sd1, rest))   unifyRows' [] REmpty [] REmpty = return ()   unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()-  unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return ()-  unifyRows' sd3 r3 sd4 r4 = throwError . errorMessage $ TypesDoNotUnify (rowFromList (sd3, r3)) (rowFromList (sd4, r4))+  unifyRows' [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) | s1 == s2 = return ()+  unifyRows' _ _ _ _ = throwError . errorMessage $ TypesDoNotUnify r1 r2  -- | -- Check that two types unify -- unifiesWith :: Type -> Type -> Bool unifiesWith (TUnknown u1) (TUnknown u2) | u1 == u2 = True-unifiesWith (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = True+unifiesWith (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = True unifiesWith (TypeVar v1) (TypeVar v2) | v1 == v2 = True unifiesWith (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True unifiesWith (TypeApp h1 t1) (TypeApp h2 t2) = h1 `unifiesWith` h2 && t1 `unifiesWith` t2@@ -187,7 +187,7 @@   go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Bool   go [] REmpty          [] REmpty          = True   go [] (TypeVar v1)    [] (TypeVar v2)    = v1 == v2-  go [] (Skolem _ s1 _) [] (Skolem _ s2 _) = s1 == s2+  go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) = s1 == s2   go [] (TUnknown _)    _  _               = True   go _  _               [] (TUnknown _)    = True   go _  (TUnknown _)    _  (TUnknown _)    = True
src/Language/PureScript/TypeClassDictionaries.hs view
@@ -1,23 +1,5 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.TypeClassDictionaries--- Copyright   :  (c) 2014 Phil Freeman--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |-----------------------------------------------------------------------------------{-# LANGUAGE DeriveDataTypeable #-}- module Language.PureScript.TypeClassDictionaries where -import Data.Data- import Language.PureScript.Names import Language.PureScript.Types @@ -29,14 +11,15 @@     -- | The identifier with which the dictionary can be accessed at runtime       tcdName :: Qualified Ident     -- | How to obtain this instance via superclass relationships-    , tcdPath :: [(Qualified ProperName, Integer)]+    , tcdPath :: [(Qualified (ProperName 'ClassName), Integer)]     -- | The name of the type class to which this type class instance applies-    , tcdClassName :: Qualified ProperName+    , tcdClassName :: Qualified (ProperName 'ClassName)     -- | The types to which this type class instance applies     , tcdInstanceTypes :: [Type]     -- | Type class dependencies which must be satisfied to construct this dictionary     , tcdDependencies :: Maybe [Constraint]-    } deriving (Show, Read, Data, Typeable)+    }+    deriving (Show, Read)  -- | -- A simplified representation of expressions which are used to represent type@@ -58,5 +41,5 @@   -- |   -- A subclass dictionary   ---  | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer+  | SubclassDictionaryValue DictionaryValue (Qualified (ProperName 'ClassName)) Integer   deriving (Show, Read, Ord, Eq)
src/Language/PureScript/Types.hs view
@@ -1,28 +1,14 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Types--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- Data types for types-----------------------------------------------------------------------------------{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} +-- |+-- Data types for types+-- module Language.PureScript.Types where  import Prelude () import Prelude.Compat -import Data.Data import Data.List (nub) import Data.Maybe (fromMaybe) import qualified Data.Aeson as A@@ -34,11 +20,13 @@ import Language.PureScript.Names import Language.PureScript.Kinds import Language.PureScript.Traversals+import Language.PureScript.AST.SourcePos  -- | -- An identifier for the scope of a skolem variable ---newtype SkolemScope = SkolemScope { runSkolemScope :: Int } deriving (Show, Read, Eq, Ord, Data, Typeable, A.ToJSON, A.FromJSON)+newtype SkolemScope = SkolemScope { runSkolemScope :: Int }+  deriving (Show, Read, Eq, Ord, A.ToJSON, A.FromJSON)  -- | -- The type of types@@ -59,7 +47,7 @@   -- |   -- A type constructor   ---  | TypeConstructor (Qualified ProperName)+  | TypeConstructor (Qualified (ProperName 'TypeName))   -- |   -- A type application   --@@ -75,7 +63,7 @@   -- |   -- A skolem constant   ---  | Skolem String Int SkolemScope+  | Skolem String Int SkolemScope (Maybe SourceSpan)   -- |   -- An empty row   --@@ -100,12 +88,13 @@   -- |   -- A placeholder used in pretty printing   ---  | PrettyPrintForAll [String] Type deriving (Show, Read,Eq, Ord, Data, Typeable)+  | PrettyPrintForAll [String] Type+  deriving (Show, Read, Eq, Ord)  -- | -- A typeclass constraint ---type Constraint = (Qualified ProperName, [Type])+type Constraint = (Qualified (ProperName 'ClassName), [Type])  $(A.deriveJSON A.defaultOptions ''Type)
src/System/IO/UTF8.hs view
@@ -1,9 +1,25 @@ module System.IO.UTF8+ where-import System.IO (hGetContents, hSetEncoding, openFile, utf8, IOMode (..)) +import System.IO ( IOMode(..)+                 , hGetContents+                 , hSetEncoding+                 , hClose+                 , hPutStr+                 , openFile+                 , utf8+                 )+ readUTF8File :: FilePath -> IO String readUTF8File inFile = do-    h <- openFile inFile ReadMode-    hSetEncoding h utf8-    hGetContents h+  h <- openFile inFile ReadMode+  hSetEncoding h utf8+  hGetContents h++writeUTF8File :: FilePath -> String -> IO ()+writeUTF8File inFile text = do+  h <- openFile inFile WriteMode+  hSetEncoding h utf8+  hPutStr h text+  hClose h
tests/Main.hs view
@@ -30,6 +30,7 @@ --   -- @shouldFailWith TypesDoNotUnify --   -- @shouldFailWith TypesDoNotUnify --   -- @shouldFailWith TransitiveExportError+--  module Main (main) where @@ -39,6 +40,7 @@ import qualified Language.PureScript as P import qualified Language.PureScript.CodeGen.JS as J import qualified Language.PureScript.CoreFn as CF+import qualified Language.PureScript.Docs as Docs  import Data.Char (isSpace) import Data.Maybe (mapMaybe, fromMaybe)@@ -68,6 +70,8 @@ import Text.Parsec (ParseError)  import TestsSetup+import TestPscPublish+import qualified TestDocs  modulesDir :: FilePath modulesDir = ".test_modules" </> "node_modules"@@ -171,6 +175,23 @@  main :: IO () main = do+  heading "Main compiler test suite"+  testCompiler+  heading "Documentation test suite"+  TestDocs.main+  -- heading "psc-publish test suite"+  -- testPscPublish++  where+  heading msg = do+    putStrLn ""+    putStrLn $ replicate 79 '#'+    putStrLn $ "# " ++ msg+    putStrLn $ replicate 79 '#'+    putStrLn ""++testCompiler :: IO ()+testCompiler = do   fetchSupportCode   cwd <- getCurrentDirectory @@ -195,13 +216,18 @@       assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns    if null failures-    then exitSuccess+    then pure ()     else do       putStrLn "Failures:"       forM_ failures $ \(fp, err) ->         let fp' = fromMaybe fp $ stripPrefix (failing ++ [pathSeparator]) fp         in putStrLn $ fp' ++ ": " ++ err       exitFailure++testPscPublish :: IO ()+testPscPublish = do+  testPackage "tests/support/prelude"+  supportModules :: [String] supportModules =
+ tests/TestDocs.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DataKinds #-}++module TestDocs where++import Prelude ()+import Prelude.Compat++import Data.Version (Version(..))++import Control.Monad hiding (forM_)+import Control.Applicative+import Control.Arrow+import Data.Maybe (fromMaybe)+import Data.List ((\\))+import Data.Foldable+import Data.Traversable+import System.Exit+import qualified Text.Parsec as Parsec++import qualified Language.PureScript as P+import qualified Language.PureScript.Docs as Docs+import qualified Language.PureScript.Publish as Publish++import qualified TestPscPublish++publishOpts :: Publish.PublishOptions+publishOpts = Publish.defaultPublishOptions+  { Publish.publishGetVersion = return testVersion+  , Publish.publishWorkingTreeDirty = return ()+  }+  where testVersion = ("v999.0.0", Version [999,0,0] [])++main :: IO ()+main = do+  TestPscPublish.pushd "examples/docs" $ do+    Docs.Package{..} <- Publish.preparePackage publishOpts+    forM_ testCases $ \(mn, pragmas) ->+      let mdl = takeJust ("module not found in docs: " ++ mn)+                         (find ((==) mn . Docs.modName) pkgModules)+      in forM_ pragmas (flip runAssertionIO mdl)++takeJust :: String -> Maybe a -> a+takeJust msg = maybe (error msg) id++data Assertion+  -- | Assert that a particular declaration is documented with the given+  -- children+  = ShouldBeDocumented P.ModuleName String [String]+  -- | Assert that a particular declaration is not documented+  | ShouldNotBeDocumented P.ModuleName String+  -- | Assert that a particular declaration exists, but without a particular+  -- child.+  | ChildShouldNotBeDocumented P.ModuleName String String+  -- | Assert that a particular declaration has a particular type class+  -- constraint.+  | ShouldBeConstrained P.ModuleName String String+  deriving (Show)++data AssertionFailure+  -- | A declaration was not documented, but should have been+  = NotDocumented P.ModuleName String+  -- | A child declaration was not documented, but should have been+  | ChildrenNotDocumented P.ModuleName String [String]+  -- | A declaration was documented, but should not have been+  | Documented P.ModuleName String+  -- | A child declaration was documented, but should not have been+  | ChildDocumented P.ModuleName String String+  -- | A constraint was missing.+  | ConstraintMissing P.ModuleName String String+  -- | A declaration had the wrong "type" (ie, value, type, type class)+  -- Fields: declaration title, expected "type", actual "type".+  | WrongDeclarationType P.ModuleName String String String+  deriving (Show)++data AssertionResult+  = Pass+  | Fail AssertionFailure+  deriving (Show)++runAssertion :: Assertion -> Docs.Module -> AssertionResult+runAssertion assertion Docs.Module{..} =+  case assertion of+    ShouldBeDocumented mn decl children ->+      case findChildren decl (declarationsFor mn) of+        Nothing ->+          Fail (NotDocumented mn decl)+        Just actualChildren ->+          case children \\ actualChildren of+            [] -> Pass+            cs -> Fail (ChildrenNotDocumented mn decl cs)++    ShouldNotBeDocumented mn decl ->+      case findChildren decl (declarationsFor mn) of+        Just _ ->+          Fail (Documented mn decl)+        Nothing ->+          Pass++    ChildShouldNotBeDocumented mn decl child ->+      case findChildren decl (declarationsFor mn) of+        Just children ->+          if child `elem` children+            then Fail (ChildDocumented mn decl child)+            else Pass+        Nothing ->+          Fail (NotDocumented mn decl)++    ShouldBeConstrained mn decl tyClass ->+      case find ((==) decl . Docs.declTitle) (declarationsFor mn) of+        Nothing ->+          Fail (NotDocumented mn decl)+        Just Docs.Declaration{..} ->+          case declInfo of+            Docs.ValueDeclaration ty ->+              if checkConstrained ty tyClass+                then Pass+                else Fail (ConstraintMissing mn decl tyClass)+            _ ->+              Fail (WrongDeclarationType mn decl "value"+                     (Docs.declInfoToString declInfo))++  where+  declarationsFor mn =+    if P.runModuleName mn == modName+      then modDeclarations+      else fromMaybe [] (lookup mn modReExports)++  findChildren title =+    fmap childrenTitles . find ((==) title . Docs.declTitle)++  childrenTitles = map Docs.cdeclTitle . Docs.declChildren++checkConstrained ty tyClass =+  -- Note that we don't recurse on ConstrainedType if none of the constraints+  -- match; this is by design, as constraints should be moved to the front+  -- anyway.+  case ty of+    P.ConstrainedType cs _ | any (matches tyClass) cs ->+      True+    P.ForAll _ ty' _ ->+      checkConstrained ty' tyClass+    _ ->+      False+  where+  matches className =+    (==) className . P.runProperName . P.disqualify . fst++runAssertionIO :: Assertion -> Docs.Module -> IO ()+runAssertionIO assertion mdl = do+  putStrLn ("In " ++ Docs.modName mdl ++ ": " ++ show assertion)+  case runAssertion assertion mdl of+    Pass -> pure ()+    fail -> do+      putStrLn (show fail)+      exitFailure++testCases :: [(String, [Assertion])]+testCases =+  [ ("Example",+      [ -- From dependencies+        ShouldBeDocumented    (n "Prelude") "Unit" []+      , ShouldNotBeDocumented (n "Prelude") "unit"++        -- From local files+      , ShouldBeDocumented    (n "Example2") "one" []+      , ShouldNotBeDocumented (n "Example2") "two"+      ])+  , ("Example2",+      [ ShouldBeDocumented (n "Example2") "one" []+      , ShouldBeDocumented (n "Example2") "two" []+      ])++  , ("UTF8",+      [ ShouldBeDocumented (n "UTF8") "thing" []+      ])++  , ("Transitive1",+      [ ShouldBeDocumented (n "Transitive2") "transitive3" []+      ])++  , ("NotAllCtors",+      [ ShouldBeDocumented         (n "Prelude") "Boolean2" ["True"]+      , ChildShouldNotBeDocumented (n "Prelude") "Boolean2" "False"+      ])++  , ("DuplicateNames",+      [ ShouldBeDocumented    (n "Prelude")        "Unit" []+      , ShouldBeDocumented    (n "DuplicateNames") "unit" []+      , ShouldNotBeDocumented (n "Prelude")        "unit"+      ])++  , ("MultiVirtual",+      [ ShouldBeDocumented (n "MultiVirtual1") "foo" []+      , ShouldBeDocumented (n "MultiVirtual2") "bar" []+      , ShouldBeDocumented (n "MultiVirtual2") "baz" []+      ])++  , ("Clash",+      [ ShouldBeDocumented (n "Clash1") "value" []+      , ShouldBeDocumented (n "Clash1") "Type" []+      , ShouldBeDocumented (n "Clash1") "TypeClass" ["typeClassMember"]+      ])++  , ("SolitaryTypeClassMember",+      [ ShouldBeDocumented    (n "SomeTypeClass") "member" []+      , ShouldNotBeDocumented (n "SomeTypeClass") "SomeClass"+      , ShouldBeConstrained   (n "SomeTypeClass") "member" "SomeClass"+      ])++  , ("ReExportedTypeClass",+      [ ShouldBeDocumented (n "SomeTypeClass") "SomeClass" ["member"]+      ])++  , ("TypeClassWithoutMembers",+      [ ShouldBeDocumented         (n "Intermediate") "SomeClass" []+      , ChildShouldNotBeDocumented (n "Intermediate") "SomeClass" "member"+      ])++  -- Remove this after 0.9.+  , ("OldOperators",+      [ ShouldBeDocumented  (n "OldOperators2") "(>>)" []+      ])++  , ("NewOperators",+      [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []+      ])+  ]++  where+  n = P.moduleNameFromString
+ tests/TestPscPublish.hs view
@@ -0,0 +1,65 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# LANGUAGE ScopedTypeVariables #-}++module TestPscPublish where++import Control.Monad+import Control.Applicative+import Control.Exception+import System.Process+import System.Directory+import System.IO+import System.Exit+import qualified Data.ByteString.Lazy as BL+import Data.ByteString.Lazy (ByteString)+import qualified Data.Aeson as A+import Data.Aeson.BetterErrors+import Data.Version++import Language.PureScript.Docs+import Language.PureScript.Publish++pushd :: forall a. FilePath -> IO a -> IO a+pushd dir act = do+  original <- getCurrentDirectory+  setCurrentDirectory dir+  result <- try act :: IO (Either IOException a)+  setCurrentDirectory original+  either throwIO return result++data TestResult+  = ParseFailed String+  | Mismatch ByteString ByteString -- ^ encoding before, encoding after+  | Pass ByteString+  deriving (Show, Read)++roundTrip :: UploadedPackage -> TestResult+roundTrip pkg =+  let before = A.encode pkg+  in case A.eitherDecode before of+       Left err -> ParseFailed err+       Right parsed -> do+         let after = A.encode (parsed :: UploadedPackage)+         if before == after+           then Pass before+           else Mismatch before after++testRunOptions :: PublishOptions+testRunOptions = defaultPublishOptions+  { publishGetVersion = return testVersion+  }+  where testVersion = ("v999.0.0", Version [999,0,0] [])++-- | Given a directory which contains a package, produce JSON from it, and then+-- | attempt to parse it again, and ensure that it doesn't change.+testPackage :: String -> IO ()+testPackage dir = do+  pushd dir $ do+    r <- roundTrip <$> preparePackage testRunOptions+    case r of+      Pass _ -> pure ()+      other -> do+        putStrLn ("psc-publish tests failed on " ++ dir ++ ":")+        putStrLn (show other)+        exitFailure
tests/support/bower.json view
@@ -2,7 +2,7 @@   "name": "purescript-test-suite-support",   "dependencies": {     "purescript-eff": "0.1.0",-    "purescript-prelude": "0.1.1",+    "purescript-prelude": "0.1.3",     "purescript-assert": "0.1.1",     "purescript-st": "0.1.0",     "purescript-console": "0.1.0",