purescript 0.6.0.2 → 0.6.1

raw patch · 51 files changed

+2152/−1695 lines, 51 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• examples/failing/TypeWildcards1.purs +4/−0
• examples/failing/TypeWildcards2.purs +4/−0
• examples/failing/TypeWildcards3.purs +7/−0
• examples/passing/Guards.purs +10/−1
• examples/passing/ImplicitEmptyImport.purs +6/−0
• examples/passing/ReservedWords.purs +13/−0
• examples/passing/TypeWildcards.purs +13/−0
• prelude/prelude.purs +10/−2
• psci/Main.hs +44/−35
• purescript.cabal +45/−35
• src/Language/PureScript.hs +3/−3
• src/Language/PureScript/AST.hs +23/−0
• src/Language/PureScript/AST/Binders.hs +86/−0
• src/Language/PureScript/AST/Declarations.hs +362/−0
• src/Language/PureScript/AST/Operators.hs +39/−0
• src/Language/PureScript/AST/SourcePos.hs +40/−0
• src/Language/PureScript/AST/Traversals.hs +383/−0
• src/Language/PureScript/CodeGen/Externs.hs +3/−3
• src/Language/PureScript/CodeGen/JS.hs +17/−13
• src/Language/PureScript/Constants.hs +3/−0
• src/Language/PureScript/DeadCodeElimination.hs +4/−4
• src/Language/PureScript/Declarations.hs +0/−849
• src/Language/PureScript/Errors.hs +1/−1
• src/Language/PureScript/ModuleDependencies.hs +1/−1
• src/Language/PureScript/Parser/Common.hs +6/−0
• src/Language/PureScript/Parser/Declarations.hs +38/−27
• src/Language/PureScript/Parser/Types.hs +15/−1
• src/Language/PureScript/Pretty/Types.hs +1/−0
• src/Language/PureScript/Pretty/Values.hs +16/−6
• src/Language/PureScript/Renamer.hs +7/−6
• src/Language/PureScript/Sugar.hs +1/−1
• src/Language/PureScript/Sugar/BindingGroups.hs +9/−9
• src/Language/PureScript/Sugar/CaseDeclarations.hs +18/−15
• src/Language/PureScript/Sugar/DoNotation.hs +2/−2
• src/Language/PureScript/Sugar/Names.hs +24/−6
• src/Language/PureScript/Sugar/Operators.hs +1/−1
• src/Language/PureScript/Sugar/TypeClasses.hs +6/−6
• src/Language/PureScript/Sugar/TypeDeclarations.hs +8/−5
• src/Language/PureScript/Traversals.hs +7/−0
• src/Language/PureScript/TypeChecker.hs +8/−8
• src/Language/PureScript/TypeChecker/Entailment.hs +217/−0
• src/Language/PureScript/TypeChecker/Kinds.hs +19/−23
• src/Language/PureScript/TypeChecker/Monad.hs +9/−11
• src/Language/PureScript/TypeChecker/Rows.hs +66/−0
• src/Language/PureScript/TypeChecker/Skolems.hs +114/−0
• src/Language/PureScript/TypeChecker/Subsumption.hs +103/−0
• src/Language/PureScript/TypeChecker/Synonyms.hs +61/−6
• src/Language/PureScript/TypeChecker/Types.hs +70/−615
• src/Language/PureScript/TypeChecker/Unify.hs +184/−0
• src/Language/PureScript/TypeClassDictionaries.hs +7/−0
• src/Language/PureScript/Types.hs +14/−0

@@ -0,0 +1,4 @@+module TypeWildcards where++type Test = _+

@@ -0,0 +1,4 @@+module TypeWildcards where++data Test = Test _+

@@ -0,0 +1,7 @@+module TypeWildcards where++data Foo a = Foo++instance showFoo :: Show (Foo _) where+  show Foo = "Foo"+

@@ -11,4 +11,13 @@     z | y > 0 -> z / 2     z -> z * 3 + 1 -  main = Debug.Trace.trace "Done"+  min :: forall a. (Ord a) => a -> a -> a+  min n m | n < m     = n+          | otherwise = m++  max :: forall a. (Ord a) => a -> a -> a+  max n m = case unit of+    _ | m < n     -> n+      | otherwise -> m++  main = Debug.Trace.trace $ min "Done" "ZZZZ"

@@ -0,0 +1,6 @@+module Main where++main = do+  Debug.Trace.trace "Hello"+  Debug.Trace.trace "Goodbye"+  Debug.Trace.trace "Done"

@@ -0,0 +1,13 @@+-- See https://github.com/purescript/purescript/issues/606+module Main where++  o :: { type :: String }+  o = { type: "o" }++  p :: { type :: String }+  p = o { type = "p" }++  f :: forall r. { type :: String | r } -> String+  f { type = "p" } = "Done"++  main = Debug.Trace.trace $ f { type: p.type, foo: "bar" }

@@ -0,0 +1,13 @@+module Main where++testTopLevel :: _ -> _+testTopLevel n = n + 1++test :: forall a. (Eq a) => (a -> a) -> a -> a+test f a = go (f a) a+  where+  go :: _ -> _ -> _+  go a1 a2 | a1 == a2 = a1+  go a1 _ = go (f a1) a1++main = Debug.Trace.trace "Done"

@@ -1,5 +1,6 @@ module Prelude-  ( flip+  ( otherwise+  , flip   , const   , asTypeOf   , Semigroupoid, (<<<), (>>>)@@ -7,7 +8,7 @@   , ($), (#)   , (:), cons   , Show, show-  , Functor, (<$>), void+  , Functor, (<$>), (<#>), void   , Apply, (<*>)   , Applicative, pure, liftA1   , Bind, (>>=)@@ -23,6 +24,9 @@   , Unit(..), unit   ) where +  otherwise :: Boolean+  otherwise = true+   flip :: forall a b c. (a -> b -> c) -> b -> a -> c   flip f b a = f a b @@ -111,9 +115,13 @@     show = showArrayImpl show    infixl 4 <$>+  infixl 1 <#>    class Functor f where     (<$>) :: forall a b. (a -> b) -> f a -> f b++  (<#>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b+  (<#>) fa f = f <$> fa    void :: forall f a. (Functor f) => f a -> f Unit   void fa = const unit <$> fa

@@ -17,46 +17,41 @@  module Main where -import Commands+import Data.Foldable (traverse_)+import Data.List (intercalate, isPrefixOf, nub, sortBy, sort)+import Data.Maybe (mapMaybe)+import Data.Traversable (traverse)+import Data.Version (showVersion)+import qualified Data.Map as M  import Control.Applicative import Control.Monad+import Control.Monad.Error (ErrorT(..), MonadError)+import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.Trans.State.Strict import qualified Control.Monad.Trans.State.Lazy as L-import Control.Monad.Error (ErrorT(..), MonadError)-import Control.Monad.Error.Class (MonadError(..)) -import Data.List (intercalate, isPrefixOf, nub, sortBy, sort)-import Data.Maybe (mapMaybe)-import Data.Foldable (traverse_)-import Data.Version (showVersion)-import Data.Traversable (traverse)--import Parser--import System.IO.Error (tryIOError) import System.Console.Haskeline-import System.Directory-       (createDirectoryIfMissing, getModificationTime, doesFileExist,-        findExecutable, getHomeDirectory, getCurrentDirectory)-import System.Process (readProcessWithExitCode)+import System.Directory (createDirectoryIfMissing, getModificationTime, doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory) import System.Exit-import System.FilePath-       (pathSeparator, takeDirectory, (</>), isPathSeparator)+import System.FilePath (pathSeparator, takeDirectory, (</>), isPathSeparator)+import System.IO.Error (tryIOError)+import System.Process (readProcessWithExitCode) import qualified System.Console.CmdTheLine as Cmd+import qualified System.IO.UTF8 as U (writeFile, putStrLn, print, readFile)  import Text.Parsec (ParseError) -import qualified Data.Map as M import qualified Language.PureScript as P-import qualified Paths_purescript as Paths-import qualified System.IO.UTF8 as U-       (writeFile, putStrLn, print, readFile)+import qualified Language.PureScript.AST as D import qualified Language.PureScript.Names as N-import qualified Language.PureScript.Declarations as D+import qualified Paths_purescript as Paths +import Commands+import Parser+ -- | -- The PSCI state. -- Holds a list of imported modules, loaded files, and partial let bindings.@@ -132,7 +127,7 @@ -- loadAllModules :: [FilePath] -> IO (Either ParseError [(Either P.RebuildPolicy FilePath, P.Module)]) loadAllModules files = do-  filesAndContent <- forM files $ \filename -> do +  filesAndContent <- forM files $ \filename -> do     content <- U.readFile filename     return (Right filename, content)   return $ P.parseModulesFromFiles (either (const "") id) $ (Left P.RebuildNever, P.prelude) : filesAndContent@@ -191,8 +186,8 @@     let matches = filter (isPrefixOf str) (names ms)     return $ sortBy sorter $ map simpleCompletion matches ++ files   getDeclName :: Maybe [P.DeclarationRef] -> P.Declaration -> Maybe P.Ident-  getDeclName Nothing (P.ValueDeclaration ident _ _ _ _) = Just ident-  getDeclName (Just exts) (P.ValueDeclaration ident _ _ _ _) | isExported = Just ident+  getDeclName Nothing (P.ValueDeclaration ident _ _ _) = Just ident+  getDeclName (Just exts) (P.ValueDeclaration ident _ _ _) | isExported = Just ident     where     isExported = any exports exts     exports (P.ValueRef ident') = ident == ident'@@ -236,9 +231,9 @@ instance P.MonadMake Make where   getTimestamp path = makeIO $ do     exists <- doesFileExist path-    case exists of-      True -> Just <$> getModificationTime path-      False -> return Nothing+    if exists+      then Just <$> getModificationTime path+      else return Nothing   readTextFile path = makeIO $ U.readFile path   writeTextFile path text = makeIO $ do     mkdirp path@@ -261,8 +256,8 @@     trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))     itValue = foldl (\x f -> f x) value lets     mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))-    itDecl = P.ValueDeclaration (P.Ident "it") P.Value [] Nothing itValue-    mainDecl = P.ValueDeclaration (P.Ident "main") P.Value [] Nothing mainValue+    itDecl = P.ValueDeclaration (P.Ident "it") P.Value [] $ Right itValue+    mainDecl = P.ValueDeclaration (P.Ident "main") P.Value [] $ Right mainValue     decls = if exec then [itDecl, mainDecl] else [itDecl]   in     P.Module moduleName ((importDecl `map` imports) ++ decls) Nothing@@ -307,7 +302,7 @@   case e of     Left err -> PSCI $ outputStrLn err     Right _ -> do-      psciIO $ writeFile indexFile $ "require('$PSCI').main();"+      psciIO $ writeFile indexFile "require('$PSCI').main();"       process <- psciIO findNodeProcess       result  <- psciIO $ traverse (\node -> readProcessWithExitCode node [indexFile] "") process       case result of@@ -316,6 +311,20 @@         Nothing                        -> PSCI $ outputStrLn "Couldn't find node.js"  -- |+-- Takes a let declaration and updates the environment, then run a make. If the declaration fails,+-- restore the pre-let environment.+--+handleLet :: (P.Expr -> P.Expr) -> PSCI ()+handleLet l = do+  st <- PSCI $ lift get+  let st' = updateLets l st+  let m = createTemporaryModule False st' (P.ObjectLiteral [])+  e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st' ++ [(Left P.RebuildAlways, m)]) []+  case e of+    Left err -> PSCI $ outputStrLn err+    Right _ -> PSCI $ lift (put st')++-- | -- Show actual loaded modules in psci. -- handleShowLoadedModules :: PSCI ()@@ -444,7 +453,7 @@ handleCommand (Expression val) = handleDeclaration val handleCommand Help = PSCI $ outputStrLn helpMessage handleCommand (Import moduleName) = handleImport moduleName-handleCommand (Let l) = PSCI $ lift $ modify (updateLets l)+handleCommand (Let l) = handleLet l handleCommand (LoadFile filePath) = do   absPath <- psciIO $ expandTilde filePath   exists <- psciIO $ doesFileExist absPath@@ -460,7 +469,7 @@   files <- psciImportedFilenames <$> PSCI (lift get)   modulesOrFirstError <- psciIO $ loadAllModules files   case modulesOrFirstError of-    Left err -> psciIO $ putStrLn (show err) >> exitFailure+    Left err -> psciIO $ print err >> exitFailure     Right modules -> PSCI . lift $ put (PSCiState files defaultImports modules []) handleCommand (TypeOf val) = handleTypeOf val handleCommand (KindOf typ) = handleKindOf typ@@ -501,7 +510,7 @@   config <- loadUserConfig   modulesOrFirstError <- loadAllModules files   case modulesOrFirstError of-    Left err -> putStrLn (show err) >> exitFailure+    Left err -> print err >> exitFailure     Right modules -> do       historyFilename <- getHistoryFilename       let settings = defaultSettings { historyFile = Just historyFilename }

@@ -1,7 +1,7 @@ name: purescript-version: 0.6.0.2+version: 0.6.1 cabal-version: >=1.8-build-type: Simple +build-type: Simple license: MIT license-file: LICENSE copyright: (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors@@ -24,54 +24,47 @@     location: https://github.com/purescript/purescript.git  library-    build-depends: base >=4 && <5, -                   cmdtheline == 0.2.*, -                   containers -any, +    build-depends: base >=4 && <5,+                   cmdtheline == 0.2.*,+                   containers -any,                    unordered-containers -any,-                   directory >= 1.2, -                   filepath -any, -                   mtl >= 2.1.0 && < 2.3.0, +                   directory >= 1.2,+                   filepath -any,+                   mtl >= 2.1.0 && < 2.3.0,                    parsec -any,-                   transformers >= 0.3 && < 0.5, +                   transformers >= 0.3 && < 0.5,                    utf8-string -any,                    pattern-arrows >= 0.0.2 && < 0.1,-                   monad-unify >= 0.2.2 && < 0.3, +                   monad-unify >= 0.2.2 && < 0.3,                    file-embed >= 0.0.7 && < 0.0.8,                    time -any     exposed-modules: Language.PureScript-                     Language.PureScript.Constants-                     Language.PureScript.Options-                     Language.PureScript.Declarations-                     Language.PureScript.Environment-                     Language.PureScript.Errors-                     Language.PureScript.Kinds-                     Language.PureScript.Names-                     Language.PureScript.Supply-                     Language.PureScript.Types-                     Language.PureScript.Traversals-                     Language.PureScript.TypeClassDictionaries-                     Language.PureScript.DeadCodeElimination-                     Language.PureScript.Sugar-                     Language.PureScript.ModuleDependencies-                     Language.PureScript.Sugar.CaseDeclarations-                     Language.PureScript.Sugar.DoNotation-                     Language.PureScript.Sugar.TypeDeclarations-                     Language.PureScript.Sugar.BindingGroups-                     Language.PureScript.Sugar.Operators-                     Language.PureScript.Sugar.TypeClasses-                     Language.PureScript.Sugar.Names+                     Language.PureScript.AST+                     Language.PureScript.AST.Binders+                     Language.PureScript.AST.Declarations+                     Language.PureScript.AST.Operators+                     Language.PureScript.AST.SourcePos+                     Language.PureScript.AST.Traversals                      Language.PureScript.CodeGen                      Language.PureScript.CodeGen.Common                      Language.PureScript.CodeGen.Externs                      Language.PureScript.CodeGen.JS                      Language.PureScript.CodeGen.JS.AST+                     Language.PureScript.Constants+                     Language.PureScript.DeadCodeElimination+                     Language.PureScript.Environment+                     Language.PureScript.Errors+                     Language.PureScript.Kinds+                     Language.PureScript.ModuleDependencies+                     Language.PureScript.Names                      Language.PureScript.Optimizer+                     Language.PureScript.Optimizer.Blocks                      Language.PureScript.Optimizer.Common+                     Language.PureScript.Optimizer.Inliner                      Language.PureScript.Optimizer.MagicDo                      Language.PureScript.Optimizer.TCO-                     Language.PureScript.Optimizer.Inliner                      Language.PureScript.Optimizer.Unused-                     Language.PureScript.Optimizer.Blocks+                     Language.PureScript.Options                      Language.PureScript.Parser                      Language.PureScript.Parser.Common                      Language.PureScript.Parser.Declarations@@ -85,11 +78,28 @@                      Language.PureScript.Pretty.Types                      Language.PureScript.Pretty.Values                      Language.PureScript.Renamer+                     Language.PureScript.Sugar+                     Language.PureScript.Sugar.BindingGroups+                     Language.PureScript.Sugar.CaseDeclarations+                     Language.PureScript.Sugar.DoNotation+                     Language.PureScript.Sugar.Names+                     Language.PureScript.Sugar.Operators+                     Language.PureScript.Sugar.TypeClasses+                     Language.PureScript.Sugar.TypeDeclarations+                     Language.PureScript.Supply+                     Language.PureScript.Traversals                      Language.PureScript.TypeChecker+                     Language.PureScript.TypeChecker.Entailment                      Language.PureScript.TypeChecker.Kinds                      Language.PureScript.TypeChecker.Monad+                     Language.PureScript.TypeChecker.Rows+                     Language.PureScript.TypeChecker.Skolems+                     Language.PureScript.TypeChecker.Subsumption                      Language.PureScript.TypeChecker.Synonyms                      Language.PureScript.TypeChecker.Types+                     Language.PureScript.TypeChecker.Unify+                     Language.PureScript.TypeClassDictionaries+                     Language.PureScript.Types     exposed: True     buildable: True     hs-source-dirs: src@@ -128,12 +138,12 @@                    Parser     ghc-options: -Wall -O2 -executable psc-docs +executable psc-docs     build-depends: base >=4 && <5, cmdtheline -any, purescript -any, utf8-string -any,                    process -any, mtl -any     main-is: Main.hs     buildable: True-    hs-source-dirs: psc-docs +    hs-source-dirs: psc-docs     other-modules:     ghc-options: -Wall -O2 

@@ -19,7 +19,7 @@  import Language.PureScript.Types as P import Language.PureScript.Kinds as P-import Language.PureScript.Declarations as P+import Language.PureScript.AST as P import Language.PureScript.Names as P import Language.PureScript.Parser as P import Language.PureScript.CodeGen as P@@ -139,7 +139,7 @@ data RebuildPolicy   -- | Never rebuild this module   = RebuildNever-  -- | Always rebuild this module +  -- | Always rebuild this module   | RebuildAlways deriving (Show, Eq, Ord)  -- |@@ -163,7 +163,7 @@      jsTimestamp <- getTimestamp jsFile     externsTimestamp <- getTimestamp externsFile-    inputTimestamp <- traverse getTimestamp inputFile +    inputTimestamp <- traverse getTimestamp inputFile      return $ case (inputTimestamp, jsTimestamp, externsTimestamp) of       (Right (Just t1), Just t2, Just t3) | t1 < min t2 t3 -> s

@@ -0,0 +1,23 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.AST+-- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- | The initial PureScript AST+--+-----------------------------------------------------------------------------++module Language.PureScript.AST (+    module AST+) where++import Language.PureScript.AST.Binders as AST+import Language.PureScript.AST.Declarations as AST+import Language.PureScript.AST.Operators as AST+import Language.PureScript.AST.SourcePos as AST+import Language.PureScript.AST.Traversals as AST

@@ -0,0 +1,86 @@+-----------------------------------------------------------------------------+--+-- 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+--+-----------------------------------------------------------------------------++{-# LANGUAGE DeriveDataTypeable #-}++module Language.PureScript.AST.Binders where++import qualified Data.Data as D++import Language.PureScript.AST.SourcePos+import Language.PureScript.Names++-- |+-- Data type for binders+--+data Binder+  -- |+  -- Wildcard binder+  --+  = NullBinder+  -- |+  -- A binder which matches a boolean literal+  --+  | BooleanBinder Bool+  -- |+  -- A binder which matches a string literal+  --+  | StringBinder String+  -- |+  -- A binder which matches a numeric literal+  --+  | NumberBinder (Either Integer Double)+  -- |+  -- A binder which binds an identifier+  --+  | VarBinder Ident+  -- |+  -- A binder which matches a data constructor+  --+  | ConstructorBinder (Qualified ProperName) [Binder]+  -- |+  -- A binder which matches a record and binds its properties+  --+  | ObjectBinder [(String, Binder)]+  -- |+  -- A binder which matches an array and binds its elements+  --+  | ArrayBinder [Binder]+  -- |+  -- A binder which matches an array and binds its head and tail+  --+  | ConsBinder Binder Binder+  -- |+  -- A binder which binds its input to an identifier+  --+  | NamedBinder Ident Binder+  -- |+  -- A binder with source position information+  --+  | PositionedBinder SourcePos Binder deriving (Show, D.Data, D.Typeable)++-- |+-- Collect all names introduced in binders in an expression+--+binderNames :: Binder -> [Ident]+binderNames = go []+  where+  go ns (VarBinder name) = name : ns+  go ns (ConstructorBinder _ bs) = foldl go ns bs+  go ns (ObjectBinder bs) = foldl go ns (map snd bs)+  go ns (ArrayBinder bs) = foldl go ns bs+  go ns (ConsBinder b1 b2) = go (go ns b1) b2+  go ns (NamedBinder name b) = go (name : ns) b+  go ns (PositionedBinder _ b) = go ns b+  go ns _ = ns

@@ -0,0 +1,362 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.AST.Declarations+-- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- | Data types for modules and declarations+--+-----------------------------------------------------------------------------++{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}++module Language.PureScript.AST.Declarations where++import qualified Data.Data as D++import Language.PureScript.AST.Binders+import Language.PureScript.AST.Operators+import Language.PureScript.AST.SourcePos+import Language.PureScript.Types+import Language.PureScript.Names+import Language.PureScript.Kinds+import Language.PureScript.TypeClassDictionaries+import Language.PureScript.CodeGen.JS.AST+import Language.PureScript.Environment++-- |+-- A module declaration, consisting of a module name, 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 ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable)++-- |+-- An item in a list of explicit imports or exports+--+data DeclarationRef+  -- |+  -- A type constructor with data constructors+  --+  = TypeRef ProperName (Maybe [ProperName])+  -- |+  -- A value+  --+  | ValueRef Ident+  -- |+  -- A type class+  --+  | TypeClassRef ProperName+    -- |+  -- A type class instance, created during typeclass desugaring (name, class name, instance types)+  --+  | TypeInstanceRef Ident+  -- |+  -- A declaration reference with source position information+  --+  | PositionedDeclarationRef SourcePos DeclarationRef+  deriving (Show, D.Data, D.Typeable)++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'+  (PositionedDeclarationRef _ r) == r' = r == r'+  r == (PositionedDeclarationRef _ r') = r == r'+  _ == _ = False++-- |+-- The data type which specifies type of import declaration+--+data ImportDeclarationType+  -- |+  -- Unqualified import+  --+  = Unqualified+  -- |+  -- Qualified import with a list of references to import+  --+  | Qualifying [DeclarationRef]+  -- |+  -- Import with hiding clause with a list of references to hide+  --+  | Hiding [DeclarationRef]+  deriving (Show, D.Data, D.Typeable)++-- |+-- The data type of declarations+--+data Declaration+  -- |+  -- A data type declaration (data or newtype, name, arguments, data constructors)+  --+  = DataDeclaration DataDeclType ProperName [(String, Maybe Kind)] [(ProperName, [Type])]+  -- |+  -- A minimal mutually recursive set of data type declarations+  --+  | DataBindingGroupDeclaration [Declaration]+  -- |+  -- A type synonym declaration (name, arguments, type)+  --+  | TypeSynonymDeclaration ProperName [(String, Maybe Kind)] Type+  -- |+  -- A type declaration for a value (name, ty)+  --+  | TypeDeclaration Ident Type+  -- |+  -- A value declaration (name, top-level binders, optional guard, value)+  --+  | ValueDeclaration Ident NameKind [Binder] (Either [(Guard, Expr)] Expr)+  -- |+  -- A minimal mutually recursive set of value declarations+  --+  | BindingGroupDeclaration [(Ident, NameKind, Expr)]+  -- |+  -- A foreign import declaration (type, name, optional inline Javascript, type)+  --+  | ExternDeclaration ForeignImportType Ident (Maybe JS) Type+  -- |+  -- A data type foreign import (name, kind)+  --+  | ExternDataDeclaration ProperName Kind+  -- |+  -- A type class instance foreign import+  --+  | ExternInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type]+  -- |+  -- A fixity declaration (fixity data, operator name)+  --+  | FixityDeclaration Fixity String+  -- |+  -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)+  --+  | ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName)+  -- |+  -- A type class declaration (name, argument, implies, member declarations)+  --+  | TypeClassDeclaration ProperName [(String, Maybe Kind)] [(Qualified ProperName, [Type])] [Declaration]+  -- |+  -- A type instance declaration (name, dependencies, class name, instance types, member+  -- declarations)+  --+  | TypeInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] [Declaration]+  -- |+  -- A declaration with source position information+  --+  | PositionedDeclaration SourcePos Declaration+  deriving (Show, D.Data, D.Typeable)++-- |+-- Test if a declaration is a value declaration+--+isValueDecl :: Declaration -> Bool+isValueDecl ValueDeclaration{} = True+isValueDecl (PositionedDeclaration _ d) = isValueDecl d+isValueDecl _ = False++-- |+-- Test if a declaration is a data type or type synonym declaration+--+isDataDecl :: Declaration -> Bool+isDataDecl DataDeclaration{} = True+isDataDecl TypeSynonymDeclaration{} = True+isDataDecl (PositionedDeclaration _ d) = isDataDecl d+isDataDecl _ = False++-- |+-- Test if a declaration is a module import+--+isImportDecl :: Declaration -> Bool+isImportDecl ImportDeclaration{} = True+isImportDecl (PositionedDeclaration _ d) = isImportDecl d+isImportDecl _ = False++-- |+-- Test if a declaration is a data type foreign import+--+isExternDataDecl :: Declaration -> Bool+isExternDataDecl ExternDataDeclaration{} = True+isExternDataDecl (PositionedDeclaration _ d) = isExternDataDecl d+isExternDataDecl _ = False++-- |+-- Test if a declaration is a type class instance foreign import+--+isExternInstanceDecl :: Declaration -> Bool+isExternInstanceDecl ExternInstanceDeclaration{} = True+isExternInstanceDecl (PositionedDeclaration _ d) = isExternInstanceDecl d+isExternInstanceDecl _ = False++-- |+-- Test if a declaration is a fixity declaration+--+isFixityDecl :: Declaration -> Bool+isFixityDecl FixityDeclaration{} = True+isFixityDecl (PositionedDeclaration _ d) = isFixityDecl d+isFixityDecl _ = False++-- |+-- Test if a declaration is a foreign import+--+isExternDecl :: Declaration -> Bool+isExternDecl ExternDeclaration{} = True+isExternDecl (PositionedDeclaration _ d) = isExternDecl d+isExternDecl _ = False++-- |+-- Test if a declaration is a type class or instance declaration+--+isTypeClassDeclaration :: Declaration -> Bool+isTypeClassDeclaration TypeClassDeclaration{} = True+isTypeClassDeclaration TypeInstanceDeclaration{} = True+isTypeClassDeclaration (PositionedDeclaration _ d) = isTypeClassDeclaration d+isTypeClassDeclaration _ = False++-- |+-- A guard is just a boolean-valued expression that appears alongside a set of binders+--+type Guard = Expr++-- |+-- Data type for expressions and terms+--+data Expr+  -- |+  -- A numeric literal+  --+  = NumericLiteral (Either Integer Double)+  -- |+  -- A string literal+  --+  | StringLiteral String+  -- |+  -- A boolean literal+  --+  | BooleanLiteral Bool+  -- |+  -- A prefix -, will be desugared+  --+  | UnaryMinus Expr+  -- |+  -- Binary operator application. During the rebracketing phase of desugaring, this data constructor+  -- will be removed.+  --+  | BinaryNoParens (Qualified Ident) Expr Expr+  -- |+  -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor+  -- will be removed.+  --+  | Parens Expr+  -- |+  -- An array literal+  --+  | ArrayLiteral [Expr]+  -- |+  -- An object literal+  --+  | ObjectLiteral [(String, Expr)]+  -- |+  -- An record property accessor expression+  --+  | Accessor String Expr+  -- |+  -- Partial record update+  --+  | ObjectUpdate Expr [(String, Expr)]+  -- |+  -- Function introduction+  --+  | Abs (Either Ident Binder) Expr+  -- |+  -- Function application+  --+  | App Expr Expr+  -- |+  -- Variable+  --+  | Var (Qualified Ident)+  -- |+  -- Conditional (if-then-else expression)+  --+  | IfThenElse Expr Expr Expr+  -- |+  -- A data constructor+  --+  | Constructor (Qualified ProperName)+  -- |+  -- 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.+  --+  | Case [Expr] [CaseAlternative]+  -- |+  -- A value with a type annotation+  --+  | TypedValue Bool Expr Type+  -- |+  -- A let binding+  --+  | Let [Declaration] Expr+  -- |+  -- A do-notation block+  --+  | Do [DoNotationElement]+  -- |+  -- An application of a typeclass dictionary constructor. The value should be+  -- an ObjectLiteral.+  --+  | TypeClassDictionaryConstructorApp (Qualified ProperName) 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+  -- can be evaluated at runtime. The constructor arguments represent (in order): whether or not to look+  -- at superclass implementations when searching for a dictionary, the type class name and+  -- instance type, and the type class dictionaries in scope.+  --+  | TypeClassDictionary Bool (Qualified ProperName, [Type]) [TypeClassDictionaryInScope]+  -- |+  -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking+  --+  | SuperClassDictionary (Qualified ProperName) [Type]+  -- |+  -- A value with source position information+  --+  | PositionedValue SourcePos Expr deriving (Show, D.Data, D.Typeable)++-- |+-- An alternative in a case statement+--+data CaseAlternative = CaseAlternative+  { -- |+    -- A collection of binders with which to match the inputs+    --+    caseAlternativeBinders :: [Binder]+    -- |+    -- The result expression or a collect of guarded expressions+    --+  , caseAlternativeResult :: Either [(Guard, Expr)] Expr+  } deriving (Show, D.Data, D.Typeable)++-- |+-- A statement in a do-notation block+--+data DoNotationElement+  -- |+  -- A monadic value without a binder+  --+  = DoNotationValue Expr+  -- |+  -- A monadic value with a binder+  --+  | DoNotationBind Binder Expr+  -- |+  -- A let statement, i.e. a pure value with a binder+  --+  | DoNotationLet [Declaration]+  -- |+  -- A do notation element with source position information+  --+  | PositionedDoNotationElement SourcePos DoNotationElement deriving (Show, D.Data, D.Typeable)

@@ -0,0 +1,39 @@+-----------------------------------------------------------------------------+--+-- 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 DeriveDataTypeable #-}++module Language.PureScript.AST.Operators where++import qualified Data.Data as D++-- |+-- A precedence level for an infix operator+--+type Precedence = Integer++-- |+-- Associativity for infix operators+--+data Associativity = Infixl | Infixr | Infix deriving (D.Data, D.Typeable)++instance Show Associativity where+  show Infixl = "infixl"+  show Infixr = "infixr"+  show Infix  = "infix"++-- |+-- Fixity data for infix operators+--+data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)

@@ -0,0 +1,40 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.AST.SourcePos+-- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- | Source position information+--+-----------------------------------------------------------------------------++{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}++module Language.PureScript.AST.SourcePos where++import qualified Data.Data as D++-- |+-- Source position information+--+data SourcePos = SourcePos+  { -- |+    -- Source name+    --+    sourceName :: String+    -- |+    -- Line number+    --+  , sourcePosLine :: Int+    -- |+    -- Column number+    --+  , sourcePosColumn :: Int+  } deriving (D.Data, D.Typeable)++instance Show SourcePos where+  show sp = sourceName sp ++ " line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp)

@@ -0,0 +1,383 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.AST.Traversals+-- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- | AST traversal helpers+--+-----------------------------------------------------------------------------++module Language.PureScript.AST.Traversals where++import Data.Monoid (Monoid(..), mconcat)++import Control.Applicative+import Control.Monad+import Control.Arrow ((***), (+++))++import Language.PureScript.AST.Binders+import Language.PureScript.AST.Declarations+import Language.PureScript.Types+import Language.PureScript.Traversals++everywhereOnValues :: (Declaration -> Declaration) ->+                      (Expr -> Expr) ->+                      (Binder -> Binder) ->+                      (Declaration -> Declaration, Expr -> Expr, Binder -> Binder)+everywhereOnValues f g h = (f', g', h')+  where+  f' :: Declaration -> Declaration+  f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (map f' ds))+  f' (ValueDeclaration name nameKind bs val) = f (ValueDeclaration name nameKind (map h' bs) ((map (g' *** g') +++ g') val))+  f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds))+  f' (TypeClassDeclaration name args implies ds) = f (TypeClassDeclaration name args implies (map f' ds))+  f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (map f' ds))+  f' (PositionedDeclaration pos d) = f (PositionedDeclaration pos (f' d))+  f' other = f other++  g' :: Expr -> Expr+  g' (UnaryMinus v) = g (UnaryMinus (g' v))+  g' (BinaryNoParens op v1 v2) = g (BinaryNoParens op (g' v1) (g' v2))+  g' (Parens v) = g (Parens (g' v))+  g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))+  g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))+  g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))+  g' (Accessor prop v) = g (Accessor prop (g' v))+  g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))+  g' (Abs name v) = g (Abs name (g' v))+  g' (App v1 v2) = g (App (g' v1) (g' v2))+  g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3))+  g' (Case vs alts) = g (Case (map g' vs) (map handleCaseAlternative alts))+  g' (TypedValue check v ty) = g (TypedValue check (g' v) ty)+  g' (Let ds v) = g (Let (map f' ds) (g' v))+  g' (Do es) = g (Do (map handleDoNotationElement es))+  g' (PositionedValue pos v) = g (PositionedValue pos (g' v))+  g' other = g other++  h' :: Binder -> Binder+  h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs))+  h' (ObjectBinder bs) = h (ObjectBinder (map (fmap h') bs))+  h' (ArrayBinder bs) = h (ArrayBinder (map h' bs))+  h' (ConsBinder b1 b2) = h (ConsBinder (h' b1) (h' b2))+  h' (NamedBinder name b) = h (NamedBinder name (h' b))+  h' (PositionedBinder pos b) = h (PositionedBinder pos (h' b))+  h' other = h other++  handleCaseAlternative :: CaseAlternative -> CaseAlternative+  handleCaseAlternative ca =+    ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)+       , caseAlternativeResult = (map (g' *** g') +++ g') (caseAlternativeResult ca)+       }++  handleDoNotationElement :: DoNotationElement -> DoNotationElement+  handleDoNotationElement (DoNotationValue v) = DoNotationValue (g' v)+  handleDoNotationElement (DoNotationBind b v) = DoNotationBind (h' b) (g' v)+  handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)+  handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos (handleDoNotationElement e)+++everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>+  (Declaration -> m Declaration) ->+  (Expr -> m Expr) ->+  (Binder -> m Binder) ->+  (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)+everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)+  where+  f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f' <=< f) ds+  f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h' <=< h) bs <*> eitherM (mapM (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val+  f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds+  f' (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f' <=< f) ds+  f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f' <=< f) ds+  f' (PositionedDeclaration pos d) = PositionedDeclaration pos <$> (f d >>= f')+  f' other = f other++  g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')+  g' (BinaryNoParens op v1 v2) = BinaryNoParens op <$> (g v1 >>= g') <*> (g v2 >>= g')+  g' (Parens v) = Parens <$> (g v >>= g')+  g' (ArrayLiteral vs) = ArrayLiteral <$> mapM (g' <=< g) vs+  g' (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g' <=< g)) vs+  g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')+  g' (Accessor prop v) = Accessor prop <$> (g v >>= g')+  g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> mapM (sndM (g' <=< g)) vs+  g' (Abs name v) = Abs name <$> (g v >>= g')+  g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g')+  g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g')+  g' (Case vs alts) = Case <$> mapM (g' <=< g) vs <*> mapM handleCaseAlternative alts+  g' (TypedValue check v ty) = TypedValue check <$> (g v >>= g') <*> pure ty+  g' (Let ds v) = Let <$> mapM (f' <=< f) ds <*> (g v >>= g')+  g' (Do es) = Do <$> mapM handleDoNotationElement es+  g' (PositionedValue pos v) = PositionedValue pos <$> (g v >>= g')+  g' other = g other++  h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h' <=< h) bs+  h' (ObjectBinder bs) = ObjectBinder <$> mapM (sndM (h' <=< h)) bs+  h' (ArrayBinder bs) = ArrayBinder <$> mapM (h' <=< h) bs+  h' (ConsBinder b1 b2) = ConsBinder <$> (h b1 >>= h') <*> (h b2 >>= h')+  h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')+  h' (PositionedBinder pos b) = PositionedBinder pos <$> (h b >>= h')+  h' other = h other++  handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM (h' <=< h) bs+                                                                   <*> eitherM (mapM (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val++  handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v+  handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v+  handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM (f' <=< f) ds+  handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos <$> handleDoNotationElement e++everywhereOnValuesM :: (Functor m, Applicative m, Monad m) =>+  (Declaration -> m Declaration) ->+  (Expr -> m Expr) ->+  (Binder -> m Binder) ->+  (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)+everywhereOnValuesM f g h = (f' <=< f, g' <=< g, h' <=< h)+  where+  f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> mapM f' ds) >>= f+  f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> mapM h' bs <*> eitherM (mapM (pairM g' g')) g' val) >>= f+  f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f+  f' (TypeClassDeclaration name args implies ds) = (TypeClassDeclaration name args implies <$> mapM f' ds) >>= f+  f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> mapM f' ds) >>= f+  f' (PositionedDeclaration pos d) = (PositionedDeclaration pos <$> f' d) >>= f+  f' other = f other++  g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g+  g' (BinaryNoParens op v1 v2) = (BinaryNoParens op <$> g' v1 <*> g' v2) >>= g+  g' (Parens v) = (Parens <$> g' v) >>= g+  g' (ArrayLiteral vs) = (ArrayLiteral <$> mapM g' vs) >>= g+  g' (ObjectLiteral vs) = (ObjectLiteral <$> mapM (sndM g') vs) >>= g+  g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g+  g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g+  g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> mapM (sndM g') vs) >>= g+  g' (Abs name v) = (Abs name <$> g' v) >>= g+  g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g+  g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g+  g' (Case vs alts) = (Case <$> mapM g' vs <*> mapM handleCaseAlternative alts) >>= g+  g' (TypedValue check v ty) = (TypedValue check <$> g' v <*> pure ty) >>= g+  g' (Let ds v) = (Let <$> mapM f' ds <*> g' v) >>= g+  g' (Do es) = (Do <$> mapM handleDoNotationElement es) >>= g+  g' (PositionedValue pos v) = (PositionedValue pos <$> g' v) >>= g+  g' other = g other++  h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> mapM h' bs) >>= h+  h' (ObjectBinder bs) = (ObjectBinder <$> mapM (sndM h') bs) >>= h+  h' (ArrayBinder bs) = (ArrayBinder <$> mapM h' bs) >>= h+  h' (ConsBinder b1 b2) = (ConsBinder <$> h' b1 <*> h' b2) >>= h+  h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h+  h' (PositionedBinder pos b) = (PositionedBinder pos <$> h' b) >>= h+  h' other = h other++  handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM h' bs+                                                                   <*> eitherM (mapM (pairM g' g')) g' val++  handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v+  handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v+  handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM f' ds+  handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos <$> handleDoNotationElement e++everythingOnValues :: (r -> r -> r) ->+                      (Declaration -> r) ->+                      (Expr -> r) ->+                      (Binder -> r) ->+                      (CaseAlternative -> r) ->+                      (DoNotationElement -> r) ->+                      (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)+everythingOnValues (<>) f g h i j = (f', g', h', i', j')+  where+  f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds)+  f' d@(ValueDeclaration _ _ bs (Right val)) = foldl (<>) (f d) (map h' bs) <> g' val+  f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)+  f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds)+  f' d@(TypeClassDeclaration _ _ _ ds) = foldl (<>) (f d) (map f' ds)+  f' d@(TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds)+  f' d@(PositionedDeclaration _ d1) = f d <> f' d1+  f' d = f d++  g' v@(UnaryMinus v1) = g v <> g' v1+  g' v@(BinaryNoParens _ v1 v2) = g v <> g' v1 <> g' v2+  g' v@(Parens v1) = g v <> g' v1+  g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)+  g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)+  g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1+  g' v@(Accessor _ v1) = g v <> g' v1+  g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)+  g' v@(Abs _ v1) = g v <> g' v1+  g' v@(App v1 v2) = g v <> g' v1 <> g' v2+  g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3+  g' v@(Case vs alts) = foldl (<>) (foldl (<>) (g v) (map g' vs)) (map i' alts)+  g' v@(TypedValue _ v1 _) = g v <> g' v1+  g' v@(Let ds v1) = foldl (<>) (g v) (map f' ds) <> g' v1+  g' v@(Do es) = foldl (<>) (g v) (map j' es)+  g' v@(PositionedValue _ v1) = g v <> g' v1+  g' v = g v++  h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs)+  h' b@(ObjectBinder bs) = foldl (<>) (h b) (map (h' . snd) bs)+  h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs)+  h' b@(ConsBinder b1 b2) = h b <> h' b1 <> h' b2+  h' b@(NamedBinder _ b1) = h b <> h' b1+  h' b@(PositionedBinder _ b1) = h b <> h' b1+  h' b = h b++  i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val+  i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)++  j' e@(DoNotationValue v) = j e <> g' v+  j' e@(DoNotationBind b v) = j e <> h' b <> g' v+  j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds)+  j' e@(PositionedDoNotationElement _ e1) = j e <> j' e1++everythingWithContextOnValues ::+  s ->+  r ->+  (r -> r -> r) ->+  (s -> Declaration       -> (s, r)) ->+  (s -> Expr              -> (s, r)) ->+  (s -> Binder            -> (s, r)) ->+  (s -> CaseAlternative   -> (s, r)) ->+  (s -> DoNotationElement -> (s, r)) ->+  ( Declaration       -> r+  , Expr              -> r+  , Binder            -> r+  , CaseAlternative   -> r+  , DoNotationElement -> r)+everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)+  where+  f'' s d = let (s', r) = f s d in r <> f' s' d++  f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds)+  f' s (ValueDeclaration _ _ bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val+  f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)+  f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> g'' s val) ds)+  f' s (TypeClassDeclaration _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)+  f' s (TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)+  f' s (PositionedDeclaration _ d1) = f'' s d1+  f' _ _ = r0++  g'' s v = let (s', r) = g s v in r <> g' s' v++  g' s (UnaryMinus v1) = g'' s v1+  g' s (BinaryNoParens _ v1 v2) = g'' s v1 <> g'' s v2+  g' s (Parens v1) = g'' s v1+  g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)+  g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)+  g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1+  g' s (Accessor _ v1) = g'' s v1+  g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)+  g' s (Abs _ v1) = 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) = foldl (<>) (foldl (<>) r0 (map (g'' s) vs)) (map (i'' s) alts)+  g' s (TypedValue _ v1 _) = g'' s v1+  g' s (Let ds v1) = foldl (<>) r0 (map (f'' s) ds) <> g'' s v1+  g' s (Do es) = foldl (<>) r0 (map (j'' s) es)+  g' s (PositionedValue _ v1) = g'' s v1+  g' _ _ = r0++  h'' s b = let (s', r) = h s b in r <> h' s' b++  h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs)+  h' s (ObjectBinder bs) = foldl (<>) r0 (map (h'' s . snd) bs)+  h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs)+  h' s (ConsBinder b1 b2) = h'' s b1 <> h'' s b2+  h' s (NamedBinder _ b1) = h'' s b1+  h' s (PositionedBinder _ b1) = h'' s b1+  h' _ _ = r0++  i'' s ca = let (s', r) = i s ca in r <> i' s' ca++  i' s (CaseAlternative bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val+  i' s (CaseAlternative bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)++  j'' s e = let (s', r) = j s e in r <> j' s' e++  j' s (DoNotationValue v) = g'' s v+  j' s (DoNotationBind b v) = h'' s b <> g'' s v+  j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds)+  j' s (PositionedDoNotationElement _ e1) = j'' s e1++everywhereWithContextOnValuesM :: (Functor m, Applicative m, Monad m) =>+  s ->+  (s -> Declaration       -> m (s, Declaration)) ->+  (s -> Expr              -> m (s, Expr)) ->+  (s -> Binder            -> m (s, Binder)) ->+  (s -> CaseAlternative   -> m (s, CaseAlternative)) ->+  (s -> DoNotationElement -> m (s, DoNotationElement)) ->+  ( Declaration       -> m Declaration+  , Expr              -> m Expr+  , Binder            -> m Binder+  , CaseAlternative   -> m CaseAlternative+  , DoNotationElement -> m DoNotationElement)+everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)+  where+  f'' s = uncurry f' <=< f s++  f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f'' s) ds+  f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h'' s) bs <*> eitherM (mapM (pairM (g'' s) (g'' s))) (g'' s) val+  f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (thirdM (g'' s)) ds+  f' s (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f'' s) ds+  f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f'' s) ds+  f' s (PositionedDeclaration pos d1) = PositionedDeclaration pos <$> f'' s d1+  f' _ other = return other++  g'' s = uncurry g' <=< g s++  g' s (UnaryMinus v) = UnaryMinus <$> g'' s v+  g' s (BinaryNoParens op v1 v2) = BinaryNoParens op <$> g'' s v1 <*> g'' s v2+  g' s (Parens v) = Parens <$> g'' s v+  g' s (ArrayLiteral vs) = ArrayLiteral <$> mapM (g'' s) vs+  g' s (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g'' s)) vs+  g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v+  g' s (Accessor prop v) = Accessor prop <$> g'' s v+  g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> mapM (sndM (g'' s)) vs+  g' s (Abs name v) = Abs name <$> g'' s v+  g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2+  g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3+  g' s (Case vs alts) = Case <$> mapM (g'' s) vs <*> mapM (i'' s) alts+  g' s (TypedValue check v ty) = TypedValue check <$> g'' s v <*> pure ty+  g' s (Let ds v) = Let <$> mapM (f'' s) ds <*> g'' s v+  g' s (Do es) = Do <$> mapM (j'' s) es+  g' s (PositionedValue pos v) = PositionedValue pos <$> g'' s v+  g' _ other = return other++  h'' s = uncurry h' <=< h s++  h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h'' s) bs+  h' s (ObjectBinder bs) = ObjectBinder <$> mapM (sndM (h'' s)) bs+  h' s (ArrayBinder bs) = ArrayBinder <$> mapM (h'' s) bs+  h' s (ConsBinder b1 b2) = ConsBinder <$> h'' s b1 <*> h'' s b2+  h' s (NamedBinder name b) = NamedBinder name <$> h'' s b+  h' s (PositionedBinder pos b) = PositionedBinder pos <$> h'' s b+  h' _ other = return other++  i'' s = uncurry i' <=< i s++  i' s (CaseAlternative bs val) = CaseAlternative <$> mapM (h'' s) bs <*> eitherM (mapM (pairM (g'' s) (g'' s))) (g'' s) val++  j'' s = uncurry j' <=< j s++  j' s (DoNotationValue v) = DoNotationValue <$> g'' s v+  j' s (DoNotationBind b v) = DoNotationBind <$> h'' s b <*> g'' s v+  j' s (DoNotationLet ds) = DoNotationLet <$> mapM (f'' s) ds+  j' s (PositionedDoNotationElement pos e1) = PositionedDoNotationElement pos <$> j'' s e1++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)+  where+  forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)+  forDecls (ExternDeclaration _ _ _ ty) = f ty+  forDecls (ExternInstanceDeclaration _ cs _ tys) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)+  forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . snd) implies)+  forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)+  forDecls (TypeSynonymDeclaration _ _ ty) = f ty+  forDecls (TypeDeclaration _ ty) = f ty+  forDecls _ = mempty++  forValues (TypeClassDictionary _ (_, cs) _) = mconcat (map f cs)+  forValues (SuperClassDictionary _ tys) = mconcat (map f tys)+  forValues (TypedValue _ _ ty) = f ty+  forValues _ = mempty

@@ -26,7 +26,7 @@  import Language.PureScript.CodeGen.Common import Language.PureScript.TypeClassDictionaries-import Language.PureScript.Declarations+import Language.PureScript.AST import Language.PureScript.Pretty import Language.PureScript.Names import Language.PureScript.Kinds@@ -87,8 +87,8 @@       case Qualified (Just moduleName) className `M.lookup` typeClasses env of         Nothing -> error $ show className ++ " has no type class definition in exportToPs"         Just (args, members, implies) -> do-          let impliesString = if null implies -                              then "" +          let impliesString = if null implies+                              then ""                               else "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) implies) ++ ") <= "               typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing className)) (map toTypeVar args)           tell ["class " ++ impliesString ++ typeName ++ " where"]

@@ -33,7 +33,7 @@ import Control.Arrow (second)  import Language.PureScript.Names-import Language.PureScript.Declarations+import Language.PureScript.AST import Language.PureScript.Options import Language.PureScript.CodeGen.JS.AST as AST import Language.PureScript.Optimizer@@ -93,7 +93,7 @@ -- Generate code in the simplified Javascript intermediate representation for a declaration -- declToJs :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName -> Declaration -> Environment -> SupplyT m (Maybe [JS])-declToJs opts mp (ValueDeclaration ident _ _ _ val) e = do+declToJs opts mp (ValueDeclaration ident _ _ (Right val)) e = do   js <- valueToJs opts mp e val   return $ Just [JSVariableIntroduction (identToJs ident) (Just js)] declToJs opts mp (BindingGroupDeclaration vals) e = do@@ -280,21 +280,25 @@ bindersToJs opts m e binders vals = do   valNames <- replicateM (length vals) freshName   let assignments = zipWith JSVariableIntroduction valNames (map Just vals)-  jss <- forM binders $ \(CaseAlternative bs grd result) -> do-    ret <- valueToJs opts m e result-    go valNames [JSReturn ret] bs grd+  jss <- forM binders $ \(CaseAlternative bs result) -> do+    ret <- guardsToJs result+    go valNames ret bs   return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") $ [JSStringLiteral "Failed pattern match"]])))                  []   where-    go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder] -> Maybe Guard -> SupplyT m [JS]-    go _ done [] Nothing = return done-    go _ done [] (Just cond) = do-      cond' <- valueToJs opts m e cond-      return [JSIfElse cond' (JSBlock done) Nothing]-    go (v:vs) done' (b:bs) grd = do-      done'' <- go vs done' bs grd+    go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder] -> SupplyT m [JS]+    go _ done [] = return done+    go (v:vs) done' (b:bs) = do+      done'' <- go vs done' bs       binderToJs m e v done'' b-    go _ _ _ _ = error "Invalid arguments to bindersToJs"+    go _ _ _ = error "Invalid arguments to bindersToJs"++    guardsToJs :: (Functor m, Applicative m, Monad m) => Either [(Guard, Expr)] Expr -> SupplyT m [JS]+    guardsToJs (Left gs) = forM gs $ \(cond, val) -> do+      cond' <- valueToJs opts m e cond+      done  <- valueToJs opts m e val+      return $ JSIfElse cond' (JSBlock [JSReturn done]) Nothing+    guardsToJs (Right v) = return . JSReturn <$> valueToJs opts m e v  -- | -- Generate code in the simplified Javascript intermediate representation for a pattern match

@@ -153,6 +153,9 @@ runFn :: String runFn = "runFn" +unit :: String+unit = "unit"+ -- Prim values  undefined :: String

@@ -21,7 +21,7 @@ import Data.Maybe (mapMaybe)  import Language.PureScript.Names-import Language.PureScript.Declarations+import Language.PureScript.AST  -- | -- Eliminate all declarations which are not a transitive dependency of the entry point module@@ -46,7 +46,7 @@   filterExport _ _ = Nothing    valueExists :: Ident -> Declaration -> Bool-  valueExists name (ValueDeclaration name' _ _ _ _) = name == name'+  valueExists name (ValueDeclaration name' _ _ _) = name == name'   valueExists name (ExternDeclaration _ name' _ _) = name == name'   valueExists name (BindingGroupDeclaration decls) = any (\(name', _, _) -> name == name') decls   valueExists name (PositionedDeclaration _ d) = valueExists name d@@ -65,7 +65,7 @@ declarationsByModule (Module moduleName ds _) = concatMap go ds   where   go :: Declaration -> [(Key, [Key])]-  go d@(ValueDeclaration name _ _ _ _) = [((moduleName, Left name), dependencies moduleName d)]+  go d@(ValueDeclaration name _ _ _) = [((moduleName, Left name), dependencies moduleName d)]   go (DataDeclaration _ _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors   go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]   go d@(BindingGroupDeclaration names') = map (\(name, _, _) -> ((moduleName, Left name), dependencies moduleName d)) names'@@ -88,7 +88,7 @@   values _ = []  isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Declaration -> Bool-isUsed moduleName graph vertexFor entryPointVertices (ValueDeclaration name _ _ _ _) =+isUsed moduleName graph vertexFor entryPointVertices (ValueDeclaration name _ _ _) =   let Just v' = vertexFor (moduleName, Left name)   in any (\v -> path graph v v') entryPointVertices isUsed moduleName graph vertexFor entryPointVertices (FixityDeclaration _ name) =

@@ -1,849 +0,0 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Declarations--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ | Data types for modules and declarations-----------------------------------------------------------------------------------{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}--module Language.PureScript.Declarations where--import Data.Monoid (Monoid(..), mconcat)--import qualified Data.Data as D--import Control.Applicative-import Control.Monad--import Language.PureScript.Types-import Language.PureScript.Names-import Language.PureScript.Kinds-import Language.PureScript.TypeClassDictionaries-import Language.PureScript.CodeGen.JS.AST-import Language.PureScript.Environment-import Language.PureScript.Traversals---- |--- A precedence level for an infix operator----type Precedence = Integer---- |--- Associativity for infix operators----data Associativity = Infixl | Infixr | Infix deriving (D.Data, D.Typeable)--instance Show Associativity where-  show Infixl = "infixl"-  show Infixr = "infixr"-  show Infix  = "infix"---- |--- Source position information----data SourcePos = SourcePos-  { -- |-    -- Source name-    ---    sourceName :: String-    -- |-    -- Line number-    ---  , sourcePosLine :: Int-    -- |-    -- Column number-    ---  , sourcePosColumn :: Int-  } deriving (D.Data, D.Typeable)--instance Show SourcePos where-  show sp = (sourceName sp) ++ " line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp)---- |--- Fixity data for infix operators----data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)---- |--- A module declaration, consisting of a module name, 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 ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable)---- |--- An item in a list of explicit imports or exports----data DeclarationRef-  -- |-  -- A type constructor with data constructors-  ---  = TypeRef ProperName (Maybe [ProperName])-  -- |-  -- A value-  ---  | ValueRef Ident-  -- |-  -- A type class-  ---  | TypeClassRef ProperName-    -- |-  -- A type class instance, created during typeclass desugaring (name, class name, instance types)-  ---  | TypeInstanceRef Ident-  -- |-  -- A declaration reference with source position information-  ---  | PositionedDeclarationRef SourcePos DeclarationRef-  deriving (Show, D.Data, D.Typeable)--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'-  (PositionedDeclarationRef _ r) == r' = r == r'-  r == (PositionedDeclarationRef _ r') = r == r'-  _ == _ = False---- |--- The data type which specifies type of import declaration----data ImportDeclarationType-  -- |-  -- Unqualified import-  ---  = Unqualified-  -- |-  -- Qualified import with a list of references to import-  ---  | Qualifying [DeclarationRef]-  -- |-  -- Import with hiding clause with a list of references to hide-  ---  | Hiding [DeclarationRef]-  deriving (Show, D.Data, D.Typeable)---- |--- The data type of declarations----data Declaration-  -- |-  -- A data type declaration (data or newtype, name, arguments, data constructors)-  ---  = DataDeclaration DataDeclType ProperName [(String, Maybe Kind)] [(ProperName, [Type])]-  -- |-  -- A minimal mutually recursive set of data type declarations-  ---  | DataBindingGroupDeclaration [Declaration]-  -- |-  -- A type synonym declaration (name, arguments, type)-  ---  | TypeSynonymDeclaration ProperName [(String, Maybe Kind)] Type-  -- |-  -- A type declaration for a value (name, ty)-  ---  | TypeDeclaration Ident Type-  -- |-  -- A value declaration (name, top-level binders, optional guard, value)-  ---  | ValueDeclaration Ident NameKind [Binder] (Maybe Guard) Expr-  -- |-  -- A minimal mutually recursive set of value declarations-  ---  | BindingGroupDeclaration [(Ident, NameKind, Expr)]-  -- |-  -- A foreign import declaration (type, name, optional inline Javascript, type)-  ---  | ExternDeclaration ForeignImportType Ident (Maybe JS) Type-  -- |-  -- A data type foreign import (name, kind)-  ---  | ExternDataDeclaration ProperName Kind-  -- |-  -- A type class instance foreign import-  ---  | ExternInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type]-  -- |-  -- A fixity declaration (fixity data, operator name)-  ---  | FixityDeclaration Fixity String-  -- |-  -- A module import (module name, optional set of identifiers to import,-  -- optional set of identifiers to hide, optional "qualified as" name)-  ---  | ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName)-  -- |-  -- A type class declaration (name, argument, implies, member declarations)-  ---  | TypeClassDeclaration ProperName [(String, Maybe Kind)] [(Qualified ProperName, [Type])] [Declaration]-  -- |-  -- A type instance declaration (name, dependencies, class name, instance types, member-  -- declarations)-  ---  | TypeInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] [Declaration]-  -- |-  -- A declaration with source position information-  ---  | PositionedDeclaration SourcePos Declaration-  deriving (Show, D.Data, D.Typeable)---- |--- Test if a declaration is a value declaration----isValueDecl :: Declaration -> Bool-isValueDecl ValueDeclaration{} = True-isValueDecl (PositionedDeclaration _ d) = isValueDecl d-isValueDecl _ = False---- |--- Test if a declaration is a data type or type synonym declaration----isDataDecl :: Declaration -> Bool-isDataDecl DataDeclaration{} = True-isDataDecl TypeSynonymDeclaration{} = True-isDataDecl (PositionedDeclaration _ d) = isDataDecl d-isDataDecl _ = False---- |--- Test if a declaration is a module import----isImportDecl :: Declaration -> Bool-isImportDecl ImportDeclaration{} = True-isImportDecl (PositionedDeclaration _ d) = isImportDecl d-isImportDecl _ = False---- |--- Test if a declaration is a data type foreign import----isExternDataDecl :: Declaration -> Bool-isExternDataDecl ExternDataDeclaration{} = True-isExternDataDecl (PositionedDeclaration _ d) = isExternDataDecl d-isExternDataDecl _ = False---- |--- Test if a declaration is a type class instance foreign import----isExternInstanceDecl :: Declaration -> Bool-isExternInstanceDecl ExternInstanceDeclaration{} = True-isExternInstanceDecl (PositionedDeclaration _ d) = isExternInstanceDecl d-isExternInstanceDecl _ = False---- |--- Test if a declaration is a fixity declaration----isFixityDecl :: Declaration -> Bool-isFixityDecl FixityDeclaration{} = True-isFixityDecl (PositionedDeclaration _ d) = isFixityDecl d-isFixityDecl _ = False---- |--- Test if a declaration is a foreign import----isExternDecl :: Declaration -> Bool-isExternDecl ExternDeclaration{} = True-isExternDecl (PositionedDeclaration _ d) = isExternDecl d-isExternDecl _ = False---- |--- Test if a declaration is a type class or instance declaration----isTypeClassDeclaration :: Declaration -> Bool-isTypeClassDeclaration TypeClassDeclaration{} = True-isTypeClassDeclaration TypeInstanceDeclaration{} = True-isTypeClassDeclaration (PositionedDeclaration _ d) = isTypeClassDeclaration d-isTypeClassDeclaration _ = False---- |--- A guard is just a boolean-valued expression that appears alongside a set of binders----type Guard = Expr---- |--- Data type for expressions and terms----data Expr-  -- |-  -- A numeric literal-  ---  = NumericLiteral (Either Integer Double)-  -- |-  -- A string literal-  ---  | StringLiteral String-  -- |-  -- A boolean literal-  ---  | BooleanLiteral Bool-  -- |-  -- A prefix -, will be desugared-  ---  | UnaryMinus Expr-  -- |-  -- Binary operator application. During the rebracketing phase of desugaring, this data constructor-  -- will be removed.-  ---  | BinaryNoParens (Qualified Ident) Expr Expr-  -- |-  -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor-  -- will be removed.-  ---  | Parens Expr-  -- |-  -- An array literal-  ---  | ArrayLiteral [Expr]-  -- |-  -- An object literal-  ---  | ObjectLiteral [(String, Expr)]-  -- |-  -- An record property accessor expression-  ---  | Accessor String Expr-  -- |-  -- Partial record update-  ---  | ObjectUpdate Expr [(String, Expr)]-  -- |-  -- Function introduction-  ---  | Abs (Either Ident Binder) Expr-  -- |-  -- Function application-  ---  | App Expr Expr-  -- |-  -- Variable-  ---  | Var (Qualified Ident)-  -- |-  -- Conditional (if-then-else expression)-  ---  | IfThenElse Expr Expr Expr-  -- |-  -- A data constructor-  ---  | Constructor (Qualified ProperName)-  -- |-  -- 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.-  ---  | Case [Expr] [CaseAlternative]-  -- |-  -- A value with a type annotation-  ---  | TypedValue Bool Expr Type-  -- |-  -- A let binding-  ---  | Let [Declaration] Expr-  -- |-  -- A do-notation block-  ---  | Do [DoNotationElement]-  -- |-  -- An application of a typeclass dictionary constructor. The value should be-  -- an ObjectLiteral.-  ---  | TypeClassDictionaryConstructorApp (Qualified ProperName) 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-  -- can be evaluated at runtime. The constructor arguments represent (in order): whether or not to look-  -- at superclass implementations when searching for a dictionary, the type class name and-  -- instance type, and the type class dictionaries in scope.-  ---  | TypeClassDictionary Bool (Qualified ProperName, [Type]) [TypeClassDictionaryInScope]-  -- |-  -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking-  ---  | SuperClassDictionary (Qualified ProperName) [Type]-  -- |-  -- A value with source position information-  ---  | PositionedValue SourcePos Expr deriving (Show, D.Data, D.Typeable)---- |--- An alternative in a case statement----data CaseAlternative = CaseAlternative-  { -- |-    -- A collection of binders with which to match the inputs-    ---    caseAlternativeBinders :: [Binder]-    -- |-    -- An optional guard-    ---  , caseAlternativeGuard :: Maybe Guard-    -- |-    -- The result expression-    ---  , caseAlternativeResult :: Expr-  } deriving (Show, D.Data, D.Typeable)---- |--- Find the original dictionary which a type class dictionary in scope refers to----canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident-canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm-canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm---- |--- A statement in a do-notation block----data DoNotationElement-  -- |-  -- A monadic value without a binder-  ---  = DoNotationValue Expr-  -- |-  -- A monadic value with a binder-  ---  | DoNotationBind Binder Expr-  -- |-  -- A let statement, i.e. a pure value with a binder-  ---  | DoNotationLet [Declaration]-  -- |-  -- A do notation element with source position information-  ---  | PositionedDoNotationElement SourcePos DoNotationElement deriving (Show, D.Data, D.Typeable)---- |--- Data type for binders----data Binder-  -- |-  -- Wildcard binder-  ---  = NullBinder-  -- |-  -- A binder which matches a boolean literal-  ---  | BooleanBinder Bool-  -- |-  -- A binder which matches a string literal-  ---  | StringBinder String-  -- |-  -- A binder which matches a numeric literal-  ---  | NumberBinder (Either Integer Double)-  -- |-  -- A binder which binds an identifier-  ---  | VarBinder Ident-  -- |-  -- A binder which matches a data constructor-  ---  | ConstructorBinder (Qualified ProperName) [Binder]-  -- |-  -- A binder which matches a record and binds its properties-  ---  | ObjectBinder [(String, Binder)]-  -- |-  -- A binder which matches an array and binds its elements-  ---  | ArrayBinder [Binder]-  -- |-  -- A binder which matches an array and binds its head and tail-  ---  | ConsBinder Binder Binder-  -- |-  -- A binder which binds its input to an identifier-  ---  | NamedBinder Ident Binder-  -- |-  -- A binder with source position information-  ---  | PositionedBinder SourcePos Binder deriving (Show, D.Data, D.Typeable)---- |--- Collect all names introduced in binders in an expression----binderNames :: Binder -> [Ident]-binderNames = go []-  where-  go ns (VarBinder name) = name : ns-  go ns (ConstructorBinder _ bs) = foldl go ns bs-  go ns (ObjectBinder bs) = foldl go ns (map snd bs)-  go ns (ArrayBinder bs) = foldl go ns bs-  go ns (ConsBinder b1 b2) = go (go ns b1) b2-  go ns (NamedBinder name b) = go (name : ns) b-  go ns (PositionedBinder _ b) = go ns b-  go ns _ = ns------- Traversals-----everywhereOnValues :: (Declaration -> Declaration) ->-                      (Expr -> Expr) ->-                      (Binder -> Binder) ->-                      (Declaration -> Declaration, Expr -> Expr, Binder -> Binder)-everywhereOnValues f g h = (f', g', h')-  where-  f' :: Declaration -> Declaration-  f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (map f' ds))-  f' (ValueDeclaration name nameKind bs grd val) = f (ValueDeclaration name nameKind (map h' bs) (fmap g' grd) (g' val))-  f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds))-  f' (TypeClassDeclaration name args implies ds) = f (TypeClassDeclaration name args implies (map f' ds))-  f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (map f' ds))-  f' (PositionedDeclaration pos d) = f (PositionedDeclaration pos (f' d))-  f' other = f other--  g' :: Expr -> Expr-  g' (UnaryMinus v) = g (UnaryMinus (g' v))-  g' (BinaryNoParens op v1 v2) = g (BinaryNoParens op (g' v1) (g' v2))-  g' (Parens v) = g (Parens (g' v))-  g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))-  g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))-  g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))-  g' (Accessor prop v) = g (Accessor prop (g' v))-  g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))-  g' (Abs name v) = g (Abs name (g' v))-  g' (App v1 v2) = g (App (g' v1) (g' v2))-  g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3))-  g' (Case vs alts) = g (Case (map g' vs) (map handleCaseAlternative alts))-  g' (TypedValue check v ty) = g (TypedValue check (g' v) ty)-  g' (Let ds v) = g (Let (map f' ds) (g' v))-  g' (Do es) = g (Do (map handleDoNotationElement es))-  g' (PositionedValue pos v) = g (PositionedValue pos (g' v))-  g' other = g other--  h' :: Binder -> Binder-  h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs))-  h' (ObjectBinder bs) = h (ObjectBinder (map (fmap h') bs))-  h' (ArrayBinder bs) = h (ArrayBinder (map h' bs))-  h' (ConsBinder b1 b2) = h (ConsBinder (h' b1) (h' b2))-  h' (NamedBinder name b) = h (NamedBinder name (h' b))-  h' (PositionedBinder pos b) = h (PositionedBinder pos (h' b))-  h' other = h other--  handleCaseAlternative :: CaseAlternative -> CaseAlternative-  handleCaseAlternative ca =-    ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)-       , caseAlternativeGuard = fmap g' (caseAlternativeGuard ca)-       , caseAlternativeResult = g' (caseAlternativeResult ca)-       }--  handleDoNotationElement :: DoNotationElement -> DoNotationElement-  handleDoNotationElement (DoNotationValue v) = DoNotationValue (g' v)-  handleDoNotationElement (DoNotationBind b v) = DoNotationBind (h' b) (g' v)-  handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)-  handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos (handleDoNotationElement e)---everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>-  (Declaration -> m Declaration) ->-  (Expr -> m Expr) ->-  (Binder -> m Binder) ->-  (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)-everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)-  where-  f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f' <=< f) ds-  f' (ValueDeclaration name nameKind bs grd val) = ValueDeclaration name nameKind <$> mapM (h' <=< h) bs <*> maybeM (g' <=< g) grd <*> (g val >>= g')-  f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds-  f' (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f' <=< f) ds-  f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f' <=< f) ds-  f' (PositionedDeclaration pos d) = PositionedDeclaration pos <$> (f d >>= f')-  f' other = f other--  g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')-  g' (BinaryNoParens op v1 v2) = BinaryNoParens op <$> (g v1 >>= g') <*> (g v2 >>= g')-  g' (Parens v) = Parens <$> (g v >>= g')-  g' (ArrayLiteral vs) = ArrayLiteral <$> mapM (g' <=< g) vs-  g' (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g' <=< g)) vs-  g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')-  g' (Accessor prop v) = Accessor prop <$> (g v >>= g')-  g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> mapM (sndM (g' <=< g)) vs-  g' (Abs name v) = Abs name <$> (g v >>= g')-  g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g')-  g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g')-  g' (Case vs alts) = Case <$> mapM (g' <=< g) vs <*> mapM handleCaseAlternative alts-  g' (TypedValue check v ty) = TypedValue check <$> (g v >>= g') <*> pure ty-  g' (Let ds v) = Let <$> mapM (f' <=< f) ds <*> (g v >>= g')-  g' (Do es) = Do <$> mapM handleDoNotationElement es-  g' (PositionedValue pos v) = PositionedValue pos <$> (g v >>= g')-  g' other = g other--  h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h' <=< h) bs-  h' (ObjectBinder bs) = ObjectBinder <$> mapM (sndM (h' <=< h)) bs-  h' (ArrayBinder bs) = ArrayBinder <$> mapM (h' <=< h) bs-  h' (ConsBinder b1 b2) = ConsBinder <$> (h b1 >>= h') <*> (h b2 >>= h')-  h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')-  h' (PositionedBinder pos b) = PositionedBinder pos <$> (h b >>= h')-  h' other = h other--  handleCaseAlternative (CaseAlternative bs grd val) = CaseAlternative <$> mapM (h' <=< h) bs-                                                                       <*> maybeM (g' <=< g) grd-                                                                       <*> (g' <=< g) val--  handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v-  handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v-  handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM (f' <=< f) ds-  handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos <$> handleDoNotationElement e--everywhereOnValuesM :: (Functor m, Applicative m, Monad m) =>-  (Declaration -> m Declaration) ->-  (Expr -> m Expr) ->-  (Binder -> m Binder) ->-  (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)-everywhereOnValuesM f g h = (f' <=< f, g' <=< g, h' <=< h)-  where-  f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> mapM f' ds) >>= f-  f' (ValueDeclaration name nameKind bs grd val) = (ValueDeclaration name nameKind <$> mapM h' bs <*> maybeM g' grd <*> g' val) >>= f-  f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f-  f' (TypeClassDeclaration name args implies ds) = (TypeClassDeclaration name args implies <$> mapM f' ds) >>= f-  f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> mapM f' ds) >>= f-  f' (PositionedDeclaration pos d) = (PositionedDeclaration pos <$> f' d) >>= f-  f' other = f other--  g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g-  g' (BinaryNoParens op v1 v2) = (BinaryNoParens op <$> (g' v1) <*> (g' v2)) >>= g-  g' (Parens v) = (Parens <$> g' v) >>= g-  g' (ArrayLiteral vs) = (ArrayLiteral <$> mapM g' vs) >>= g-  g' (ObjectLiteral vs) = (ObjectLiteral <$> mapM (sndM g') vs) >>= g-  g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g-  g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g-  g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> mapM (sndM g') vs) >>= g-  g' (Abs name v) = (Abs name <$> g' v) >>= g-  g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g-  g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g-  g' (Case vs alts) = (Case <$> mapM g' vs <*> mapM handleCaseAlternative alts) >>= g-  g' (TypedValue check v ty) = (TypedValue check <$> g' v <*> pure ty) >>= g-  g' (Let ds v) = (Let <$> mapM f' ds <*> g' v) >>= g-  g' (Do es) = (Do <$> mapM handleDoNotationElement es) >>= g-  g' (PositionedValue pos v) = (PositionedValue pos <$> g' v) >>= g-  g' other = g other--  h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> mapM h' bs) >>= h-  h' (ObjectBinder bs) = (ObjectBinder <$> mapM (sndM h') bs) >>= h-  h' (ArrayBinder bs) = (ArrayBinder <$> mapM h' bs) >>= h-  h' (ConsBinder b1 b2) = (ConsBinder <$> h' b1 <*> h' b2) >>= h-  h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h-  h' (PositionedBinder pos b) = (PositionedBinder pos <$> h' b) >>= h-  h' other = h other--  handleCaseAlternative (CaseAlternative bs grd val) = CaseAlternative <$> mapM h' bs-                                                                       <*> maybeM g' grd-                                                                       <*> g' val--  handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v-  handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v-  handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM f' ds-  handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos <$> handleDoNotationElement e--everythingOnValues :: (r -> r -> r) ->-                      (Declaration -> r) ->-                      (Expr -> r) ->-                      (Binder -> r) ->-                      (CaseAlternative -> r) ->-                      (DoNotationElement -> r) ->-                      (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)-everythingOnValues (<>) f g h i j = (f', g', h', i', j')-  where-  f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds)-  f' d@(ValueDeclaration _ _ bs Nothing val) = foldl (<>) (f d) (map h' bs) <> g' val-  f' d@(ValueDeclaration _ _ bs (Just grd) val) = foldl (<>) (f d) (map h' bs) <> g' grd <> g' val-  f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds)-  f' d@(TypeClassDeclaration _ _ _ ds) = foldl (<>) (f d) (map f' ds)-  f' d@(TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds)-  f' d@(PositionedDeclaration _ d1) = f d <> f' d1-  f' d = f d--  g' v@(UnaryMinus v1) = g v <> g' v1-  g' v@(BinaryNoParens _ v1 v2) = g v <> g' v1 <> g' v2-  g' v@(Parens v1) = g v <> g' v1-  g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)-  g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)-  g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1-  g' v@(Accessor _ v1) = g v <> g' v1-  g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)-  g' v@(Abs _ v1) = g v <> g' v1-  g' v@(App v1 v2) = g v <> g' v1 <> g' v2-  g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3-  g' v@(Case vs alts) = foldl (<>) (foldl (<>) (g v) (map g' vs)) (map i' alts)-  g' v@(TypedValue _ v1 _) = g v <> g' v1-  g' v@(Let ds v1) = (foldl (<>) (g v) (map f' ds)) <> g' v1-  g' v@(Do es) = foldl (<>) (g v) (map j' es)-  g' v@(PositionedValue _ v1) = g v <> g' v1-  g' v = g v--  h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs)-  h' b@(ObjectBinder bs) = foldl (<>) (h b) (map (h' . snd) bs)-  h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs)-  h' b@(ConsBinder b1 b2) = h b <> h' b1 <> h' b2-  h' b@(NamedBinder _ b1) = h b <> h' b1-  h' b@(PositionedBinder _ b1) = h b <> h' b1-  h' b = h b--  i' ca = case caseAlternativeGuard ca of-    Nothing -> foldl (<>) (i ca) (map h' (caseAlternativeBinders ca)) <> g' (caseAlternativeResult ca)-    Just grd -> foldl (<>) (i ca) (map h' (caseAlternativeBinders ca)) <> g' grd <> g' (caseAlternativeResult ca)--  j' e@(DoNotationValue v) = j e <> g' v-  j' e@(DoNotationBind b v) = j e <> h' b <> g' v-  j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds)-  j' e@(PositionedDoNotationElement _ e1) = j e <> j' e1--everythingWithContextOnValues ::-  s ->-  r ->-  (r -> r -> r) ->-  (s -> Declaration       -> (s, r)) ->-  (s -> Expr             -> (s, r)) ->-  (s -> Binder            -> (s, r)) ->-  (s -> CaseAlternative   -> (s, r)) ->-  (s -> DoNotationElement -> (s, r)) ->-  ( Declaration       -> r-  , Expr             -> r-  , Binder            -> r-  , CaseAlternative   -> r-  , DoNotationElement -> r)-everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)-  where-  f'' s d = let (s', r) = f s d in r <> f' s' d--  f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds)-  f' s (ValueDeclaration _ _ bs Nothing val) = foldl (<>) r0 (map (h'' s) bs) <> (g'' s) val-  f' s (ValueDeclaration _ _ bs (Just grd) val) = foldl (<>) r0 (map (h'' s) bs) <> (g'' s) grd <> (g'' s) val-  f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> (g'' s) val) ds)-  f' s (TypeClassDeclaration _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)-  f' s (TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)-  f' s (PositionedDeclaration _ d1) = (f'' s) d1-  f' _ _ = r0--  g'' s v = let (s', r) = g s v in r <> g' s' v--  g' s (UnaryMinus v1) = (g'' s) v1-  g' s (BinaryNoParens _ v1 v2) = (g'' s) v1 <> (g'' s) v2-  g' s (Parens v1) = (g'' s) v1-  g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)-  g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)-  g' s (TypeClassDictionaryConstructorApp _ v1) = (g'' s) v1-  g' s (Accessor _ v1) = (g'' s) v1-  g' s (ObjectUpdate obj vs) = foldl (<>) ((g'' s) obj) (map (g'' s . snd) vs)-  g' s (Abs _ v1) = (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) = foldl (<>) (foldl (<>) r0 (map (g'' s) vs)) (map (i'' s) alts)-  g' s (TypedValue _ v1 _) = (g'' s) v1-  g' s (Let ds v1) = (foldl (<>) r0 (map (f'' s) ds)) <> (g'' s) v1-  g' s (Do es) = foldl (<>) r0 (map (j'' s) es)-  g' s (PositionedValue _ v1) = (g'' s) v1-  g' _ _ = r0--  h'' s b = let (s', r) = h s b in r <> h' s' b--  h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs)-  h' s (ObjectBinder bs) = foldl (<>) r0 (map (h'' s . snd) bs)-  h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs)-  h' s (ConsBinder b1 b2) = (h'' s) b1 <> (h'' s) b2-  h' s (NamedBinder _ b1) = (h'' s) b1-  h' s (PositionedBinder _ b1) = (h'' s) b1-  h' _ _ = r0--  i'' s ca = let (s', r) = i s ca in r <> i' s' ca--  i' s (CaseAlternative bs Nothing val) = foldl (<>) r0 (map (h'' s) bs) <> (g'' s) val-  i' s (CaseAlternative bs (Just grd) val) = foldl (<>) r0 (map (h'' s) bs) <> (g'' s) grd <> (g'' s) val--  j'' s e = let (s', r) = j s e in r <> j' s' e--  j' s (DoNotationValue v) = (g'' s) v-  j' s (DoNotationBind b v) =  (h'' s) b <> (g'' s) v-  j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds)-  j' s (PositionedDoNotationElement _ e1) = (j'' s) e1--everywhereWithContextOnValuesM :: (Functor m, Applicative m, Monad m) =>-  s ->-  (s -> Declaration       -> m (s, Declaration)) ->-  (s -> Expr             -> m (s, Expr)) ->-  (s -> Binder            -> m (s, Binder)) ->-  (s -> CaseAlternative   -> m (s, CaseAlternative)) ->-  (s -> DoNotationElement -> m (s, DoNotationElement)) ->-  ( Declaration       -> m Declaration-  , Expr             -> m Expr-  , Binder            -> m Binder-  , CaseAlternative   -> m CaseAlternative-  , DoNotationElement -> m DoNotationElement)-everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)-  where-  f'' s = uncurry f' <=< f s--  f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f'' s) ds-  f' s (ValueDeclaration name nameKind bs grd val) = ValueDeclaration name nameKind <$> mapM (h'' s) bs <*> maybeM (g'' s) grd <*> g'' s val-  f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (thirdM (g'' s)) ds-  f' s (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f'' s) ds-  f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f'' s) ds-  f' s (PositionedDeclaration pos d1) = PositionedDeclaration pos <$> f'' s d1-  f' _ other = return other--  g'' s = uncurry g' <=< g s--  g' s (UnaryMinus v) = UnaryMinus <$> g'' s v-  g' s (BinaryNoParens op v1 v2) = BinaryNoParens op <$> g'' s v1 <*> g'' s v2-  g' s (Parens v) = Parens <$> g'' s v-  g' s (ArrayLiteral vs) = ArrayLiteral <$> mapM (g'' s) vs-  g' s (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g'' s)) vs-  g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g'' s) v-  g' s (Accessor prop v) = Accessor prop <$> g'' s v-  g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> mapM (sndM (g'' s)) vs-  g' s (Abs name v) = Abs name <$> g'' s v-  g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2-  g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3-  g' s (Case vs alts) = Case <$> mapM (g'' s) vs <*> mapM (i'' s) alts-  g' s (TypedValue check v ty) = TypedValue check <$> g'' s v <*> pure ty-  g' s (Let ds v) = Let <$> mapM (f'' s) ds <*> g'' s v-  g' s (Do es) = Do <$> mapM (j'' s) es-  g' s (PositionedValue pos v) = PositionedValue pos <$> g'' s v-  g' _ other = return other--  h'' s = uncurry h' <=< h s--  h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h'' s) bs-  h' s (ObjectBinder bs) = ObjectBinder <$> mapM (sndM (h'' s)) bs-  h' s (ArrayBinder bs) = ArrayBinder <$> mapM (h'' s) bs-  h' s (ConsBinder b1 b2) = ConsBinder <$> h'' s b1 <*> h'' s b2-  h' s (NamedBinder name b) = NamedBinder name <$> h'' s b-  h' s (PositionedBinder pos b) = PositionedBinder pos <$> h'' s b-  h' _ other = return other--  i'' s = uncurry i' <=< i s--  i' s (CaseAlternative bs grd val) = CaseAlternative <$> mapM (h'' s) bs <*> maybeM (g'' s) grd <*> g'' s val--  j'' s = uncurry j' <=< j s--  j' s (DoNotationValue v) = DoNotationValue <$> g'' s v-  j' s (DoNotationBind b v) = DoNotationBind <$> h'' s b <*> g'' s v-  j' s (DoNotationLet ds) = DoNotationLet <$> mapM (f'' s) ds-  j' s (PositionedDoNotationElement pos e1) = PositionedDoNotationElement pos <$> j'' s e1--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)-  where-  forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)-  forDecls (ExternDeclaration _ _ _ ty) = f ty-  forDecls (ExternInstanceDeclaration _ cs _ tys) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)-  forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . snd) implies)-  forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)-  forDecls (TypeSynonymDeclaration _ _ ty) = f ty-  forDecls (TypeDeclaration _ ty) = f ty-  forDecls _ = mempty--  forValues (TypeClassDictionary _ (_, cs) _) = mconcat (map f cs)-  forValues (SuperClassDictionary _ tys) = mconcat (map f tys)-  forValues (TypedValue _ _ ty) = f ty-  forValues _ = mempty--

@@ -23,7 +23,7 @@ import Control.Monad.Error import Control.Applicative ((<$>)) -import Language.PureScript.Declarations+import Language.PureScript.AST import Language.PureScript.Pretty import Language.PureScript.Types 

@@ -21,7 +21,7 @@ import Data.List (nub) import Data.Maybe (mapMaybe) -import Language.PureScript.Declarations+import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Types 

@@ -134,6 +134,12 @@ identifier = PT.identifier tokenParser  -- |+-- Parse an identifier in a more permissive position+--+identifierName :: P.Parsec String u String+identifierName = lexeme $ (:) <$> identStart <*> many identLetter++-- | -- Parse a reserved word -- reserved :: String -> P.Parsec String u ()

@@ -35,7 +35,7 @@ import Language.PureScript.Kinds import Language.PureScript.Parser.State import Language.PureScript.Parser.Common-import Language.PureScript.Declarations+import Language.PureScript.AST import Language.PureScript.Parser.Types import Language.PureScript.Parser.Kinds import Language.PureScript.CodeGen.JS.AST@@ -54,7 +54,7 @@   toSourcePos p = SourcePos (P.sourceName p) (P.sourceLine p) (P.sourceColumn p)  kindedIdent :: P.Parsec String ParseState (String, Maybe Kind)-kindedIdent = (, Nothing) <$> identifier +kindedIdent = (, Nothing) <$> identifier           <|> parens ((,) <$> identifier <*> (Just <$> (indented *> lexeme (P.string "::") *> indented *> parseKind)))  parseDataDeclaration :: P.Parsec String ParseState Declaration@@ -64,7 +64,7 @@   tyArgs <- many (indented *> kindedIdent)   ctors <- P.option [] $ do     _ <- lexeme $ indented *> P.char '='-    sepBy1 ((,) <$> properName <*> P.many (indented *> parseTypeAtom)) pipe+    sepBy1 ((,) <$> properName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe   return $ DataDeclaration dtype name tyArgs ctors  parseTypeDeclaration :: P.Parsec String ParseState Declaration@@ -76,20 +76,28 @@ parseTypeSynonymDeclaration =   TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName)                          <*> many (indented *> kindedIdent)-                         <*> (lexeme (indented *> P.char '=') *> parsePolyType)+                         <*> (lexeme (indented *> P.char '=') *> noWildcards parsePolyType)  parseValueDeclaration :: P.Parsec String ParseState Declaration parseValueDeclaration = do   name <- parseIdent   binders <- P.many parseBinderNoParens-  guard <- P.optionMaybe parseGuard-  value <- lexeme (indented *> P.char '=') *> parseValue-  whereClause <- P.optionMaybe $ do-    C.indented-    reserved "where"-    C.indented-    C.mark $ P.many1 (C.same *> parseLocalDeclaration)-  return $ ValueDeclaration name Value binders guard (maybe value (`Let` value) whereClause)+  value <- Left <$> (C.indented *>+                       C.mark (P.many1 ((,) <$> (C.same *> parseGuard)+                                            <*> (lexeme (indented *> P.char '=') *> parseValueWithWhereClause)+                                       )))+       <|> Right <$> (lexeme (indented *> P.char '=') *> parseValueWithWhereClause)+  return $ ValueDeclaration name Value binders value+  where+  parseValueWithWhereClause :: P.Parsec String ParseState Expr+  parseValueWithWhereClause = do+    value <- parseValue+    whereClause <- P.optionMaybe $ do+      C.indented+      reserved "where"+      C.indented+      C.mark $ P.many1 (C.same *> parseLocalDeclaration)+    return $ maybe value (`Let` value) whereClause  parseExternDeclaration :: P.Parsec String ParseState Declaration parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *>@@ -98,16 +106,16 @@    <|> (do reserved "instance"            name <- parseIdent <* lexeme (indented *> P.string "::")            deps <- P.option [] $ do-             deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom))+             deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))              indented              reservedOp "=>"              return deps            className <- indented *> parseQualified properName-           tys <- P.many (indented *> parseTypeAtom)+           tys <- P.many (indented *> noWildcards parseTypeAtom)            return $ ExternInstanceDeclaration name deps className tys)    <|> (do ident <- parseIdent            js <- P.optionMaybe (JSRaw <$> stringLiteral)-           ty <- lexeme (indented *> P.string "::") *> parsePolyType+           ty <- lexeme (indented *> P.string "::") *> noWildcards parsePolyType            return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty))  parseAssociativity :: P.Parsec String ParseState Associativity@@ -168,7 +176,7 @@   reserved "class"   implies <- P.option [] $ do     indented-    implies <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom))+    implies <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))     reservedOp "<="     return implies   className <- indented *> properName@@ -183,12 +191,12 @@   reserved "instance"   name <- parseIdent <* lexeme (indented *> P.string "::")   deps <- P.optionMaybe $ do-    deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom))+    deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))     indented     reservedOp "=>"     return deps   className <- indented *> parseQualified properName-  ty <- P.many (indented *> parseTypeAtom)+  ty <- P.many (indented *> (noWildcards parseTypeAtom))   members <- P.option [] . P.try $ do     indented *> reserved "where"     mark (P.many (same *> positioned parseValueDeclaration))@@ -233,10 +241,10 @@   return $ Module name decls exports  -- |--- Parse a collection of modules +-- Parse a collection of modules -- parseModulesFromFiles :: (k -> String) -> [(k, String)] -> Either P.ParseError [(k, Module)]-parseModulesFromFiles toFilePath input = +parseModulesFromFiles toFilePath input =   fmap collect . forM input $ \(filename, content) -> do     ms <- runIndentParser (toFilePath filename) parseModules content     return (filename, ms)@@ -269,7 +277,7 @@ parseObjectLiteral = ObjectLiteral <$> C.braces (C.commaSep parseIdentifierAndValue)  parseIdentifierAndValue :: P.Parsec String ParseState (String, Expr)-parseIdentifierAndValue = (,) <$> (C.indented *> (C.identifier <|> C.stringLiteral) <* C.indented <* C.colon)+parseIdentifierAndValue = (,) <$> (C.indented *> (C.identifierName <|> C.stringLiteral) <* C.indented <* C.colon)                               <*> (C.indented *> parseValue)  parseAbs :: P.Parsec String ParseState Expr@@ -295,8 +303,11 @@  parseCaseAlternative :: P.Parsec String ParseState CaseAlternative parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)-                                       <*> P.optionMaybe parseGuard-                                       <*> (C.indented *> C.reservedOp "->" *> parseValue)+                                       <*> (Left <$> (C.indented *>+                                                        C.mark (P.many1 ((,) <$> (C.same *> parseGuard)+                                                                             <*> (lexeme (indented *> C.reservedOp "->") *> parseValue)+                                                                        )))+                                            <|> Right <$> (lexeme (indented *> C.reservedOp "->") *> parseValue))                                        P.<?> "case alternative"  parseIfThenElse :: P.Parsec String ParseState Expr@@ -332,14 +343,14 @@  parsePropertyUpdate :: P.Parsec String ParseState (String, Expr) parsePropertyUpdate = do-  name <- C.lexeme (C.identifier <|> C.stringLiteral)+  name <- C.lexeme (C.identifierName <|> C.stringLiteral)   _ <- C.lexeme $ C.indented *> P.char '='   value <- C.indented *> parseValue   return (name, value)  parseAccessor :: Expr -> P.Parsec String ParseState Expr parseAccessor (Constructor _) = P.unexpected "constructor"-parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> (C.identifier <|> C.stringLiteral)) <*> pure obj+parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> (C.identifierName <|> C.stringLiteral)) <*> pure obj  parseDo :: P.Parsec String ParseState Expr parseDo = do@@ -419,7 +430,7 @@  parseIdentifierAndBinder :: P.Parsec String ParseState (String, Binder) parseIdentifierAndBinder = do-  name <- C.lexeme (C.identifier <|> C.stringLiteral)+  name <- C.lexeme (C.identifierName <|> C.stringLiteral)   _ <- C.lexeme $ C.indented *> P.char '='   binder <- C.indented *> parseBinder   return (name, binder)@@ -464,6 +475,6 @@ -- Parse a guard -- parseGuard :: P.Parsec String ParseState Guard-parseGuard = C.indented *> C.pipe *> C.indented *> parseValue+parseGuard = C.pipe *> C.indented *> parseValue  

@@ -16,6 +16,7 @@ module Language.PureScript.Parser.Types (     parseType,     parsePolyType,+    noWildcards,     parseTypeAtom ) where @@ -43,6 +44,9 @@ parseObject :: P.Parsec String ParseState Type parseObject = braces $ TypeApp tyObject <$> parseRow +parseTypeWildcard :: P.Parsec String ParseState Type+parseTypeWildcard = lexeme (P.char '_') >> return TypeWildcard+ parseTypeVariable :: P.Parsec String ParseState Type parseTypeVariable = do   ident <- identifier@@ -65,6 +69,7 @@             , parseArrayOf             , parseFunction             , parseObject+            , parseTypeWildcard             , parseTypeVariable             , parseTypeConstructor             , parseForAll@@ -108,8 +113,17 @@ parsePolyType :: P.Parsec String ParseState Type parsePolyType = parseAnyType +-- |+-- Parse an atomic type with no wildcards+--+noWildcards :: P.Parsec String ParseState Type -> P.Parsec String ParseState Type+noWildcards p = do+  ty <- p+  when (containsWildcards ty) $ P.unexpected "type wildcard"+  return ty+ parseNameAndType :: P.Parsec String ParseState t -> P.Parsec String ParseState (String, t)-parseNameAndType p = (,) <$> (indented *> (identifier <|> stringLiteral) <* indented <* lexeme (P.string "::")) <*> p+parseNameAndType p = (,) <$> (indented *> (identifierName <|> stringLiteral) <* indented <* lexeme (P.string "::")) <*> p  parseRowEnding :: P.Parsec String ParseState Type parseRowEnding = P.option REmpty (TypeVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier))

@@ -34,6 +34,7 @@ typeLiterals :: Pattern () Type String typeLiterals = mkPattern match   where+  match TypeWildcard = Just "_"         match (TypeVar var) = Just var   match (PrettyPrintObject row) = Just $ "{ " ++ prettyPrintRow row ++ " }"   match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"

@@ -26,7 +26,7 @@ import Control.Monad.State import Control.Applicative -import Language.PureScript.Declarations+import Language.PureScript.AST import Language.PureScript.Pretty.Common import Language.PureScript.Pretty.Types (prettyPrintType) @@ -86,7 +86,7 @@  prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String prettyPrintDeclaration (TypeDeclaration ident ty) = return $ show ident ++ " :: " ++ prettyPrintType ty-prettyPrintDeclaration (ValueDeclaration ident _ [] Nothing val) = fmap concat $ sequence+prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) = fmap concat $ sequence   [ return $ show ident ++ " = "   , prettyPrintValue' val   ]@@ -94,13 +94,23 @@ prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"  prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String-prettyPrintCaseAlternative (CaseAlternative binders grd val) =+prettyPrintCaseAlternative (CaseAlternative binders result) =   fmap concat $ sequence     [ intercalate ", " <$> forM binders prettyPrintBinder'-    , maybe (return "") (fmap ("| " ++) . prettyPrintValue') grd-    , return " -> "-    , prettyPrintValue' val+    , prettyPrintResult result     ]+  where+  prettyPrintResult (Left gs) = concat <$> mapM prettyPrintGuardedValue gs+  prettyPrintResult (Right v) = (" -> " ++) <$> prettyPrintValue' v++  prettyPrintGuardedValue (grd, val) =+    fmap concat $ sequence+      [ return "| "+      , prettyPrintValue' grd+      , return " -> "+      , prettyPrintValue' val+      , return "\n"+      ]  prettyPrintDoNotationElement :: DoNotationElement -> StateT PrinterState Maybe String prettyPrintDoNotationElement (DoNotationValue val) =

@@ -23,7 +23,7 @@ import qualified Data.Map as M import qualified Data.Set as S -import Language.PureScript.Declarations+import Language.PureScript.AST import Language.PureScript.Environment import Language.PureScript.Names import Language.PureScript.Traversals@@ -103,7 +103,7 @@ findDeclIdents :: [Declaration] -> [Ident] findDeclIdents = concatMap go   where-  go (ValueDeclaration ident _ _ _ _) = [ident]+  go (ValueDeclaration ident _ _ _) = [ident]   go (BindingGroupDeclaration ds) = map (\(name, _, _) -> name) ds   go (ExternDeclaration _ ident _ _) = [ident]   go (TypeClassDeclaration _ _ _ ds) = findDeclIdents ds@@ -129,9 +129,9 @@ -- another in the current scope. -- renameInDecl :: Bool -> Declaration -> Rename Declaration-renameInDecl isTopLevel (ValueDeclaration name nameKind [] Nothing val) = do+renameInDecl isTopLevel (ValueDeclaration name nameKind [] (Right val)) = do   name' <- if isTopLevel then return name else updateScope name-  ValueDeclaration name' nameKind [] Nothing <$> renameInValue val+  ValueDeclaration name' nameKind [] . Right <$> renameInValue val renameInDecl isTopLevel (BindingGroupDeclaration ds) = do   ds' <- mapM updateNames ds   BindingGroupDeclaration <$> mapM updateValues ds'@@ -187,8 +187,9 @@ -- Renames within case alternatives. -- renameInCaseAlternative :: CaseAlternative -> Rename CaseAlternative-renameInCaseAlternative (CaseAlternative bs g v) =-  CaseAlternative <$> mapM renameInBinder bs <*> maybeM renameInValue g <*> renameInValue v+renameInCaseAlternative (CaseAlternative bs v) =+  CaseAlternative <$> mapM renameInBinder bs+                  <*> eitherM (mapM (pairM renameInValue renameInValue)) renameInValue v  -- | -- Renames within binders.

@@ -19,7 +19,7 @@ import Control.Category ((>>>)) import Control.Monad.Trans.Class -import Language.PureScript.Declarations+import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Supply 

@@ -29,7 +29,7 @@  import qualified Data.Set as S -import Language.PureScript.Declarations+import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Types import Language.PureScript.Environment@@ -84,7 +84,7 @@ 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 [] Nothing val) ds+  go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds   go (PositionedDeclaration pos d) = map (PositionedDeclaration pos) $ go d   go other = [other] @@ -98,13 +98,13 @@   in nub . f   where   def s _ = (s, [])-  +   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, [])-  +   usedNamesB :: S.Set Ident -> Binder -> (S.Set Ident, [Ident])   usedNamesB scope binder = (scope `S.union` S.fromList (binderNames binder), []) @@ -114,7 +114,7 @@   in nub . f   where   def s _ = (s, [])-  +   usedNamesE :: Bool -> Expr -> (Bool, [Ident])   usedNamesE True (Var (Qualified Nothing name)) = (True, [name])   usedNamesE True (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = (True, [name])@@ -135,7 +135,7 @@   usedNames _ = []  getIdent :: Declaration -> Ident-getIdent (ValueDeclaration ident _ _ _ _) = ident+getIdent (ValueDeclaration ident _ _ _) = ident getIdent (PositionedDeclaration _ d) = getIdent d getIdent _ = error "Expected ValueDeclaration" @@ -147,8 +147,8 @@  -- | -- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).---  --+-- toBindingGroup :: ModuleName -> SCC Declaration -> Either ErrorStack Declaration toBindingGroup _ (AcyclicSCC d) = return d toBindingGroup _ (CyclicSCC [d]) = return d@@ -176,7 +176,7 @@    cycleError :: Declaration -> [Declaration] -> Either ErrorStack a   cycleError (PositionedDeclaration p d) ds = rethrowWithPosition p $ cycleError d ds-  cycleError (ValueDeclaration n _ _ _ e) [] = Left $+  cycleError (ValueDeclaration n _ _ (Right e)) [] = Left $     mkErrorStack ("Cycle in definition of " ++ show n) (Just (ExprError e))   cycleError d ds@(_:_) = rethrow (<> mkErrorStack ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing) $ cycleError d []   cycleError _ _ = error "Expected ValueDeclaration"@@ -197,7 +197,7 @@ isTypeSynonym _ = Nothing  fromValueDecl :: Declaration -> (Ident, NameKind, Expr)-fromValueDecl (ValueDeclaration ident nameKind [] Nothing val) = (ident, nameKind, val)+fromValueDecl (ValueDeclaration ident nameKind [] (Right val)) = (ident, nameKind, val) fromValueDecl ValueDeclaration{} = error "Binders should have been desugared" fromValueDecl (PositionedDeclaration _ d) = fromValueDecl d fromValueDecl _ = error "Expected ValueDeclaration"

@@ -19,7 +19,7 @@     desugarCasesModule ) where -import Data.Maybe (isJust)+import Data.Either (isLeft) import Data.Monoid ((<>)) import Data.List (nub, groupBy) @@ -28,10 +28,11 @@ import Control.Monad.Error.Class  import Language.PureScript.Names-import Language.PureScript.Declarations+import Language.PureScript.AST import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Supply+import Language.PureScript.Traversals import Language.PureScript.TypeChecker.Monad (guardWith)  -- |@@ -50,7 +51,7 @@   replace :: Expr -> SupplyT (Either ErrorStack) Expr   replace (Abs (Right binder) val) = do     ident <- Ident <$> freshName-    return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing val]+    return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)]   replace other = return other  -- |@@ -62,9 +63,11 @@     desugarRest :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]     desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =       (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest-    desugarRest (ValueDeclaration name nameKind bs g val : rest) =+    desugarRest (ValueDeclaration name nameKind bs result : rest) =       let (_, f, _) = everywhereOnValuesTopDownM return go return-      in (:) <$> (ValueDeclaration name nameKind bs g <$> f val) <*> desugarRest rest+          f' (Left gs) = Left <$> mapM (pairM return f) gs+          f' (Right v) = Right <$> f v+      in (:) <$> (ValueDeclaration name nameKind bs <$> f' result) <*> desugarRest rest       where       go (Let ds val') = Let <$> desugarCases ds <*> pure val'       go other = return other@@ -75,22 +78,22 @@     desugarRest [] = pure []  inSameGroup :: Declaration -> Declaration -> Bool-inSameGroup (ValueDeclaration ident1 _ _ _ _) (ValueDeclaration ident2 _ _ _ _) = ident1 == ident2+inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2 inSameGroup (PositionedDeclaration _ d1) d2 = inSameGroup d1 d2 inSameGroup d1 (PositionedDeclaration _ d2) = inSameGroup d1 d2 inSameGroup _ _ = False  toDecls :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]-toDecls [ValueDeclaration ident nameKind bs Nothing val] | all isVarBinder bs = do+toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = do   let args = map (\(VarBinder arg) -> arg) bs       body = foldr (Abs . Left) val args   guardWith (strMsg "Overlapping function argument names") $ length (nub args) == length args-  return [ValueDeclaration ident nameKind [] Nothing body]-toDecls ds@(ValueDeclaration ident _ bs g _ : _) = do+  return [ValueDeclaration ident nameKind [] (Right body)]+toDecls ds@(ValueDeclaration ident _ bs result : _) = do   let tuples = map toTuple ds   unless (all ((== length bs) . length . fst) tuples) $       throwError $ mkErrorStack ("Argument list lengths differ in declaration " ++ show ident) Nothing-  unless (not (null bs) || isJust g) $+  unless (not (null bs) || isLeft result) $       throwError $ mkErrorStack ("Duplicate value declaration '" ++ show ident ++ "'") Nothing   caseDecl <- makeCaseDeclaration ident tuples   return [caseDecl]@@ -103,18 +106,18 @@ isVarBinder (VarBinder _) = True isVarBinder _ = False -toTuple :: Declaration -> ([Binder], (Maybe Guard, Expr))-toTuple (ValueDeclaration _ _ bs g val) = (bs, (g, val))+toTuple :: Declaration -> ([Binder], Either [(Guard, Expr)] Expr)+toTuple (ValueDeclaration _ _ bs result) = (bs, result) toTuple (PositionedDeclaration _ d) = toTuple d toTuple _ = error "Not a value declaration" -makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Expr))] -> SupplyT (Either ErrorStack) Declaration+makeCaseDeclaration :: Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> SupplyT (Either ErrorStack) Declaration makeCaseDeclaration ident alternatives = do   let argPattern = length . fst . head $ alternatives   args <- map Ident <$> replicateM argPattern freshName   let     vars = map (Var . Qualified Nothing) args-    binders = [ CaseAlternative bs g val | (bs, (g, val)) <- alternatives ]+    binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]     value = foldr (Abs . Left) (Case vars binders) args-  return $ ValueDeclaration ident Value [] Nothing value+  return $ ValueDeclaration ident Value [] (Right value) 

@@ -19,7 +19,7 @@ ) where  import Language.PureScript.Names-import Language.PureScript.Declarations+import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Supply @@ -66,7 +66,7 @@   go (DoNotationBind binder val : rest) = do     rest' <- go rest     ident <- Ident <$> freshName-    return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing rest']))+    return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')]))   go [DoNotationLet _] = lift $ Left $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing   go (DoNotationLet ds : rest) = do     rest' <- go rest

@@ -4,7 +4,7 @@ -- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors -- License     :  MIT ----- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Maintainer  :  Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com> -- Stability   :  experimental -- Portability : --@@ -16,6 +16,7 @@   desugarImports ) where +import Data.List (nub) import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Monoid ((<>)) @@ -24,7 +25,7 @@  import qualified Data.Map as M -import Language.PureScript.Declarations+import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Types import Language.PureScript.Environment@@ -158,7 +159,7 @@       let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports       let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports       imports <- resolveImports env m-      renameInModule imports env (elaborateExports exps m)+      elaborateImports <$> renameInModule imports env (elaborateExports exps m)  -- | -- Make all exports for a module explicit. This may still effect modules that have an exports list,@@ -171,6 +172,23 @@   map ValueRef (exportedValues 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 :: Module -> Module+elaborateImports (Module mn decls exps) = Module 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']+  fqValues _ = []+  mkImport :: ModuleName -> Declaration+  mkImport mn' = ImportDeclaration mn' (Qualifying []) Nothing++-- | -- Replaces all local names with qualified names within a module and checks that all existing -- qualified names are valid. --@@ -222,10 +240,10 @@   updateBinder s v = return (s, v)    updateCase :: (Maybe SourcePos, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourcePos, [Ident]), CaseAlternative)-  updateCase (pos, bound) c@(CaseAlternative bs _ _) = return ((pos, concatMap binderNames bs ++ bound), c)+  updateCase (pos, bound) c@(CaseAlternative bs _) = return ((pos, concatMap binderNames bs ++ bound), c)    letBoundVariable :: Declaration -> Maybe Ident-  letBoundVariable (ValueDeclaration ident _ _ _ _) = Just ident+  letBoundVariable (ValueDeclaration ident _ _ _) = Just ident   letBoundVariable (PositionedDeclaration _ d) = letBoundVariable d   letBoundVariable _ = Nothing @@ -304,7 +322,7 @@   addDecl mn env (DataDeclaration _ tn _ dcs) = addType env mn tn (map fst dcs)   addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []   addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []-  addDecl mn env (ValueDeclaration name _ _ _ _) = addValue env mn name+  addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name   addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name   addDecl mn env (PositionedDeclaration _ d) = addDecl mn env d   addDecl _  env _ = return env

@@ -25,7 +25,7 @@ ) where  import Language.PureScript.Names-import Language.PureScript.Declarations+import Language.PureScript.AST import Language.PureScript.Errors  import Control.Applicative

@@ -18,7 +18,7 @@   desugarTypeClasses ) where -import Language.PureScript.Declarations+import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Types import Language.PureScript.Kinds@@ -211,7 +211,7 @@  typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =-  ValueDeclaration ident TypeClassAccessorImport [] Nothing $+  ValueDeclaration ident TypeClassAccessorImport [] $ Right $     TypedValue False (Abs (Left $ Ident "dict") (Accessor (runIdent ident) (Var $ Qualified Nothing (Ident "dict")))) $     moveQuantifiersToFront (quantify (ConstrainedType [(Qualified (Just mn) name, map (TypeVar . fst) args)] ty)) typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =@@ -258,19 +258,19 @@           dictTy = foldl TypeApp (TypeConstructor className) tys           constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)           dict = TypeClassDictionaryConstructorApp className memberNames'-          result = ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)+          result = ValueDeclaration name TypeInstanceDictionaryValue [] (Right (TypedValue True dict constrainedTy))       return result    where    declName :: Declaration -> Maybe Ident   declName (PositionedDeclaration _ d) = declName d-  declName (ValueDeclaration ident _ _ _ _) = Just ident+  declName (ValueDeclaration ident _ _ _) = Just ident   declName (TypeDeclaration ident _) = Just ident   declName _ = Nothing    memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Expr)-  memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do+  memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _) = do     _ <- lift . lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'     let memberValue = typeInstanceDictionaryEntryValue d     return (ident, memberValue)@@ -280,7 +280,7 @@   memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"    typeInstanceDictionaryEntryValue :: Declaration -> Expr-  typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] _ val) = val+  typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] (Right val)) = val   typeInstanceDictionaryEntryValue (PositionedDeclaration pos d) = PositionedValue pos (typeInstanceDictionaryEntryValue d)   typeInstanceDictionaryEntryValue _ = error "Invalid declaration in type instance definition" 

@@ -25,10 +25,11 @@ import Control.Monad.Error.Class import Control.Monad (forM) -import Language.PureScript.Declarations+import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Environment import Language.PureScript.Errors+import Language.PureScript.Traversals  -- | -- Replace all top level type declarations in a module with type annotations@@ -47,18 +48,20 @@   return (PositionedDeclaration pos d' : ds') desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do   (_, nameKind, val) <- fromValueDeclaration d-  desugarTypeDeclarations (ValueDeclaration name nameKind [] Nothing (TypedValue True val ty) : rest)+  desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)   where   fromValueDeclaration :: Declaration -> Either ErrorStack (Ident, NameKind, Expr)-  fromValueDeclaration (ValueDeclaration name' nameKind [] Nothing val) | name == name' = return (name', nameKind, val)+  fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)   fromValueDeclaration (PositionedDeclaration pos d') = do     (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'     return (ident, nameKind, PositionedValue pos val)   fromValueDeclaration _ = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing-desugarTypeDeclarations (ValueDeclaration name nameKind bs g val : rest) = do+desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do   let (_, f, _) = everywhereOnValuesTopDownM return go return-  (:) <$> (ValueDeclaration name nameKind bs g <$> f val) <*> desugarTypeDeclarations rest+      f' (Left gs) = Left <$> mapM (pairM return f) gs+      f' (Right v) = Right <$> f v+  (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations rest   where   go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val'   go other = return other

@@ -25,9 +25,16 @@ thirdM :: (Functor f) => (c -> f d) -> (a, b, c) -> f (a, b, d) thirdM f (a, b, c) = (,,) a b <$> f c +pairM :: (Applicative f) => (a -> f c) -> (b -> f d) -> (a, b) -> f (c, d)+pairM f g (a, b)  = (,) <$> f a <*> g b+ maybeM :: (Applicative f) => (a -> f b) -> Maybe a -> f (Maybe b) maybeM _ Nothing = pure Nothing maybeM f (Just a) = Just <$> f a++eitherM :: (Applicative f) => (a -> f c) -> (b -> f d) -> Either a b -> f (Either c d)+eitherM f _ (Left a)  = Left  <$> f a+eitherM _ g (Right b) = Right <$> g b  defS :: (Monad m) => st -> val -> m (st, val) defS s val = return (s, val)

@@ -37,7 +37,7 @@ import Language.PureScript.Types import Language.PureScript.Names import Language.PureScript.Kinds-import Language.PureScript.Declarations+import Language.PureScript.AST import Language.PureScript.TypeClassDictionaries import Language.PureScript.Environment import Language.PureScript.Errors@@ -145,7 +145,7 @@       (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)       forM_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do         checkDuplicateTypeArguments $ map fst args-        let args' = args `withKinds` ctorKind +        let args' = args `withKinds` ctorKind         addDataType moduleName dtype name args' dctors ctorKind       forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do         checkDuplicateTypeArguments $ map fst args@@ -169,12 +169,12 @@     ds <- go rest     return $ TypeSynonymDeclaration name args ty : ds   go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"-  go (ValueDeclaration name nameKind [] Nothing val : rest) = do+  go (ValueDeclaration name nameKind [] (Right val) : rest) = do     d <- rethrow (strMsg ("Error in declaration " ++ show name) <>) $ do       valueIsNotDefined moduleName name       [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]       addValue moduleName name ty nameKind-      return $ ValueDeclaration name nameKind [] Nothing val'+      return $ ValueDeclaration name nameKind [] $ Right val'     ds <- go rest     return $ d : ds   go (ValueDeclaration{} : _) = error "Binders were not desugared"@@ -183,10 +183,10 @@       forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->         valueIsNotDefined moduleName name       tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals-      vals' <- forM [ (name, val, nameKind, ty) +      vals' <- forM [ (name, val, nameKind, ty)                     | (name, nameKind, _) <- vals                     , (name', (val, ty)) <- tys-                    , name == name' +                    , name == name'                     ] $ \(name, val, nameKind, ty) -> do         addValue moduleName name ty nameKind         return (name, nameKind, val)@@ -248,9 +248,9 @@     rethrowWithPosition pos $ do       (d' : rest') <- go (d : rest)       return (PositionedDeclaration pos d' : rest')-  +   -- |-  -- This function adds the argument kinds for a type constructor so that they may appear in the externs file, +  -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,   -- extracted from the kind of the type constructor itself.   --   withKinds :: [(String, Maybe Kind)] -> Kind -> [(String, Maybe Kind)]

@@ -0,0 +1,217 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.TypeChecker.Entailment+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- Type class entailment+--+-----------------------------------------------------------------------------++module Language.PureScript.TypeChecker.Entailment (+    entails+) where++import Data.Function (on)+import Data.List+import Data.Maybe (maybeToList)+import qualified Data.Map as M++import Control.Applicative+import Control.Arrow (Arrow(..))+import Control.Monad.Error++import Language.PureScript.AST+import Language.PureScript.Environment+import Language.PureScript.Names+import Language.PureScript.Pretty+import Language.PureScript.TypeChecker.Monad+import Language.PureScript.TypeChecker.Synonyms+import Language.PureScript.TypeChecker.Unify+import Language.PureScript.TypeClassDictionaries+import Language.PureScript.Types+import qualified Language.PureScript.Constants as C++-- |+-- A simplified representation of expressions which are used to represent type+-- class dictionaries at runtime, which can be compared for equality+--+data DictionaryValue+  -- |+  -- A dictionary which is brought into scope by a local constraint+  --+  = LocalDictionaryValue (Qualified Ident)+  -- |+  -- A dictionary which is brought into scope by an instance declaration+  --+  | GlobalDictionaryValue (Qualified Ident)+  -- |+  -- A dictionary which depends on other dictionaries+  --+  | DependentDictionaryValue (Qualified Ident) [DictionaryValue]+  -- |+  -- A subclass dictionary+  --+  | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer+  deriving (Show, Ord, Eq)++-- |+-- 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 :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Bool -> Check Expr+entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filter filterModule context))+  where+    sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v]+    sortedNubBy f vs = M.elems (M.fromList (map (f &&& id) vs))++    -- Filter out type dictionaries which are in scope in the current module+    filterModule :: TypeClassDictionaryInScope -> Bool+    filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True+    filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True+    filterModule _ = False++    solve context' (className, tys) trySuperclasses =+      checkOverlaps $ go trySuperclasses className tys+      where+      go trySuperclasses' className' tys' =+        -- Look for regular type instances+        [ mkDictionary (canonicalizeDictionary tcd) args+        | tcd <- context'+        -- Make sure the type class name matches the one we are trying to satisfy+        , className' == tcdClassName tcd+        -- Make sure the type unifies with the type in the type instance definition+        , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)+        -- Solve any necessary subgoals+        , args <- solveSubgoals subst (tcdDependencies tcd) ] ++++        -- Look for implementations via superclasses+        [ SubclassDictionaryValue suDict superclass index+        | trySuperclasses'+        , (subclassName, (args, _, implies)) <- M.toList (typeClasses env)+        -- Try each superclass+        , (index, (superclass, suTyArgs)) <- zip [0..] implies+        -- Make sure the type class name matches the superclass name+        , className' == superclass+        -- Make sure the types unify with the types in the superclass implication+        , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs+        -- Finally, satisfy the subclass constraint+        , args' <- maybeToList $ mapM ((`lookup` subst) . fst) args+        , suDict <- go True subclassName args' ]++      -- Create dictionaries for subgoals which still need to be solved by calling go recursively+      -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type+      -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.+      solveSubgoals :: [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [DictionaryValue]]+      solveSubgoals _ Nothing = return Nothing+      solveSubgoals subst (Just subgoals) = do+        dict <- mapM (uncurry (go True) . second (map (replaceAllTypeVars subst))) subgoals+        return $ Just dict+      -- Make a dictionary from subgoal dictionaries by applying the correct function+      mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue+      mkDictionary fnName Nothing = LocalDictionaryValue fnName+      mkDictionary fnName (Just []) = GlobalDictionaryValue fnName+      mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts+      -- Turn a DictionaryValue into a Expr+      dictionaryValueToValue :: DictionaryValue -> Expr+      dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName+      dictionaryValueToValue (GlobalDictionaryValue fnName) = Var fnName+      dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)+      dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) =+        App (Accessor (C.__superclass_ ++ show superclassName ++ "_" ++ show index)+                      (dictionaryValueToValue dict))+            valUndefined+      -- Ensure that a substitution is valid+      verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]+      verifySubstitution subst = do+        let grps = groupBy ((==) `on` fst) subst+        guard (all (pairwise (unifiesWith env) . map snd) grps)+        return $ map head grps+      -- |+      -- Check for overlapping instances+      --+      checkOverlaps :: [DictionaryValue] -> Check Expr+      checkOverlaps dicts =+        case [ (d1, d2) | d1 <- dicts, d2 <- dicts, d1 `overlapping` d2 ] of+          (d1, d2) : _ -> throwError . strMsg $ unlines+            [ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintType tys) ++ "."+            , "For example:"+            , prettyPrintDictionaryValue d1+            , "and:"+            , prettyPrintDictionaryValue d2+            ]+          _ -> case chooseSimplestDictionaries dicts of+                 [] -> throwError . strMsg $+                         "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)+                 d : _ -> return $ dictionaryValueToValue d+      -- Choose the simplest DictionaryValues from a list of candidates+      -- The reason for this function is as follows:+      -- When considering overlapping instances, we don't want to consider the same dictionary+      -- to be an overlap of itself when obtained as a superclass of another class.+      -- Observing that we probably don't want to select a superclass instance when an instance+      -- is available directly, and that there is no way for a superclass instance to actually+      -- introduce an overlap that wouldn't have been there already, we simply remove dictionaries+      -- obtained as superclass instances if there are simpler instances available.+      chooseSimplestDictionaries :: [DictionaryValue] -> [DictionaryValue]+      chooseSimplestDictionaries ds = case filter isSimpleDictionaryValue ds of+                                        [] -> ds+                                        simple -> simple+      isSimpleDictionaryValue SubclassDictionaryValue{} = False+      isSimpleDictionaryValue (DependentDictionaryValue _ ds) = all isSimpleDictionaryValue ds+      isSimpleDictionaryValue _ = True+      -- |+      -- Check if two dictionaries are overlapping+      --+      -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have+      -- been caught when constructing superclass dictionaries.+      --+      overlapping :: DictionaryValue -> DictionaryValue -> Bool+      overlapping (LocalDictionaryValue nm1)         (LocalDictionaryValue nm2)  | nm1 == nm2 = False+      overlapping (GlobalDictionaryValue nm1)        (GlobalDictionaryValue nm2) | nm1 == nm2 = False+      overlapping (DependentDictionaryValue nm1 ds1) (DependentDictionaryValue nm2 ds2)+        | nm1 == nm2 = or $ zipWith overlapping ds1 ds2+      overlapping SubclassDictionaryValue{} _ = False+      overlapping _ SubclassDictionaryValue{} = False+      overlapping _ _ = True+      -- |+      -- Render a DictionaryValue fit for human consumption in error messages+      --+      prettyPrintDictionaryValue :: DictionaryValue -> String+      prettyPrintDictionaryValue = unlines . indented 0+        where+        indented n (LocalDictionaryValue _)           = [spaces n ++ "Dictionary in scope"]+        indented n (GlobalDictionaryValue nm)         = [spaces n ++ show nm]+        indented n (DependentDictionaryValue nm args) = (spaces n ++ show nm ++ " via") : concatMap (indented (n + 2)) args+        indented n (SubclassDictionaryValue sup nm _) = (spaces n ++ show nm ++ " via superclass") : indented (n + 2) sup++        spaces n = replicate n ' ' ++ "- "++    valUndefined :: Expr+    valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))++-- |+-- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup),+-- and return a substitution from type variables to types which makes the type heads unify.+--+typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]+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 e (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m e h1 h2 <*> typeHeadsAreEqual m e t1 t2+typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e name args of+  Left  _  -> Nothing+  Right t1 -> typeHeadsAreEqual m e t1 t2+typeHeadsAreEqual _ _ _ _ = Nothing++-- |+-- Check all values in a list pairwise match a predicate+--+pairwise :: (a -> a -> Bool) -> [a] -> Bool+pairwise _ [] = True+pairwise _ [_] = True+pairwise p (x : xs) = all (p x) xs && pairwise p xs

@@ -22,23 +22,23 @@     kindsOfAll ) where -import Language.PureScript.Types-import Language.PureScript.Kinds-import Language.PureScript.Names-import Language.PureScript.TypeChecker.Monad-import Language.PureScript.Pretty-import Language.PureScript.Environment-import Language.PureScript.Errors+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import qualified Data.HashMap.Strict as H+import qualified Data.Map as M -import Control.Monad.State+import Control.Applicative import Control.Monad.Error+import Control.Monad.State import Control.Monad.Unify -import Control.Applicative--import qualified Data.Map as M-import qualified Data.HashMap.Strict as H-import Data.Monoid ((<>))+import Language.PureScript.Environment+import Language.PureScript.Errors+import Language.PureScript.Kinds+import Language.PureScript.Names+import Language.PureScript.Pretty+import Language.PureScript.TypeChecker.Monad+import Language.PureScript.Types  instance Partial Kind where   unknown = KUnknown@@ -50,9 +50,7 @@     go _ = []   ($?) sub = everywhereOnKinds go     where-    go t@(KUnknown u) = case H.lookup u (runSubstitution sub) of-                          Nothing -> t-                          Just t' -> t'+    go t@(KUnknown u) = fromMaybe t $ H.lookup u (runSubstitution sub)     go other = other  instance Unifiable Check Kind where@@ -85,12 +83,12 @@   tyCon <- fresh   kargs <- replicateM (length args) fresh   rest <- zipWithM freshKindVar args kargs-  let dict = (name, tyCon) : rest +  let dict = (name, tyCon) : rest   bindLocalTypeVariables moduleName dict $     solveTypes isData ts kargs tyCon   where   tidyUp (k, sub) = starIfUnknown $ sub $? k-  + freshKindVar :: (String, Maybe Kind) -> Kind -> UnifyT Kind Check (ProperName, Kind) freshKindVar (arg, Nothing) kind = return (ProperName arg, kind) freshKindVar (arg, Just kind') kind = do@@ -125,13 +123,13 @@ -- | -- Solve the set of kind constraints associated with the data constructors for a type constructor ---solveTypes :: Bool -> [Type] -> [Kind] -> Kind -> UnifyT Kind (Check) Kind+solveTypes :: Bool -> [Type] -> [Kind] -> Kind -> UnifyT Kind Check Kind solveTypes isData ts kargs tyCon = do   ks <- mapM infer ts   when isData $ do     tyCon =?= foldr FunKind Star kargs     forM_ ks $ \k -> k =?= Star-  when (not isData) $ do+  unless isData $     tyCon =?= foldr FunKind (head ks) kargs   return tyCon @@ -151,6 +149,7 @@ infer ty = rethrow (mkErrorStack "Error inferring type of value" (Just (TypeError ty)) <>) $ infer' ty  infer' :: Type -> UnifyT Kind Check Kind+infer' TypeWildcard = fresh infer' (TypeVar v) = do   Just moduleName <- checkCurrentModule <$> get   UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))@@ -191,6 +190,3 @@   k =?= k'   return k' infer' _ = error "Invalid argument to infer"---

@@ -18,23 +18,21 @@  module Language.PureScript.TypeChecker.Monad where -import Language.PureScript.Types-import Language.PureScript.Kinds-import Language.PureScript.Names-import Language.PureScript.Declarations (canonicalizeDictionary)-import Language.PureScript.Environment-import Language.PureScript.TypeClassDictionaries-import Language.PureScript.Options-import Language.PureScript.Errors- import Data.Maybe+import qualified Data.Map as M  import Control.Applicative-import Control.Monad.State import Control.Monad.Error+import Control.Monad.State import Control.Monad.Unify -import qualified Data.Map as M+import Language.PureScript.Environment+import Language.PureScript.Errors+import Language.PureScript.Kinds+import Language.PureScript.Names+import Language.PureScript.Options+import Language.PureScript.TypeClassDictionaries+import Language.PureScript.Types  -- | -- Temporarily bind a collection of names to values

@@ -0,0 +1,66 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.TypeChecker.Rows+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- Functions relating to type checking for rows+--+-----------------------------------------------------------------------------++module Language.PureScript.TypeChecker.Rows (+    checkDuplicateLabels+) where++import Data.List++import Control.Monad.Error++import Language.PureScript.AST+import Language.PureScript.Errors+import Language.PureScript.TypeChecker.Monad+import Language.PureScript.Types++-- |+-- Ensure rows do not contain duplicate labels+--+checkDuplicateLabels :: Expr -> Check ()+checkDuplicateLabels =+  let (_, f, _) = everywhereOnValuesM def go def+  in void . f+  where+  def :: a -> Check a+  def = return++  go :: Expr -> Check Expr+  go e@(TypedValue _ val ty) = do+    checkDups ty+    return e++    where+    checkDups :: Type -> Check ()+    checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2+    checkDups (SaturatedTypeSynonym _ ts) = mapM_ checkDups ts+    checkDups (ForAll _ t _) = checkDups t+    checkDups (ConstrainedType args t) = do+      mapM_ checkDups $ concatMap snd args+      checkDups t+    checkDups r@RCons{} =+      let (ls, _) = rowToList r in+      case firstDup . sort . map fst $ ls of+        Just l -> throwError $ mkErrorStack ("Duplicate label " ++ show l ++ " in row") $ Just (ExprError val)+        Nothing -> return ()+    checkDups _ = return ()++    firstDup :: (Eq a) => [a] -> Maybe a+    firstDup (x : xs@(x' : _))+      | x == x' = Just x+      | otherwise = firstDup xs+    firstDup _ = Nothing++  go other = return other

@@ -0,0 +1,114 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.TypeChecker.Skolems+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- Functions relating to skolemization used during typechecking+--+-----------------------------------------------------------------------------++module Language.PureScript.TypeChecker.Skolems (+    newSkolemConstant,+    introduceSkolemScope,+    newSkolemScope,+    skolemize,+    skolemizeTypesInValue,+    skolemEscapeCheck+) where++import Data.List (nub, (\\))+import Data.Monoid++import Control.Applicative+import Control.Monad.Error+import Control.Monad.Unify++import Language.PureScript.AST+import Language.PureScript.Errors+import Language.PureScript.Pretty+import Language.PureScript.TypeChecker.Monad+import Language.PureScript.Types++-- |+-- Generate a new skolem constant+--+newSkolemConstant :: UnifyT Type Check Int+newSkolemConstant = fresh'++-- |+-- Introduce skolem scope at every occurence of a ForAll+--+introduceSkolemScope :: Type -> UnifyT Type Check Type+introduceSkolemScope = everywhereOnTypesM go+  where+  go (ForAll ident ty Nothing) = ForAll ident ty <$> (Just <$> newSkolemScope)+  go other = return other++-- |+-- Generate a new skolem scope+--+newSkolemScope :: UnifyT Type Check SkolemScope+newSkolemScope = SkolemScope <$> fresh'++-- |+-- 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)++-- |+-- 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 = let (_, f, _) = everywhereOnValues id go id in f+  where+  go (SuperClassDictionary c ts) = SuperClassDictionary c (map (skolemize ident sko scope) ts)+  go other = other++-- |+-- Ensure skolem variables do not escape their scope+--+skolemEscapeCheck :: Expr -> Check ()+skolemEscapeCheck (TypedValue False _ _) = return ()+skolemEscapeCheck root@TypedValue{} =+  -- Every skolem variable is created when a ForAll type is skolemized.+  -- This determines the scope of that skolem variable, which is copied from the SkolemScope+  -- field of the ForAll constructor.+  -- We traverse the tree top-down, and collect any SkolemScopes introduced by ForAlls.+  -- If a Skolem is encountered whose SkolemScope is not in the current list, we have found+  -- an escaped skolem variable.+  let (_, f, _, _, _) = everythingWithContextOnValues [] [] (++) def go def def def+  in case f root of+       [] -> return ()+       ((binding, val) : _) -> throwError $ mkErrorStack ("Rigid/skolem type variable " ++ maybe "" (("bound by " ++) . prettyPrintValue) binding ++ " has escaped.") (Just (ExprError val))+  where+  def s _ = (s, [])++  go :: [(SkolemScope, Expr)] -> Expr -> ([(SkolemScope, Expr)], [(Maybe Expr, Expr)])+  go scos val@(TypedValue _ _ (ForAll _ _ (Just sco))) = ((sco, val) : scos, [])+  go scos val@(TypedValue _ _ ty) = case collectSkolems ty \\ map fst scos of+                                      (sco : _) -> (scos, [(findBindingScope sco, val)])+                                      _ -> (scos, [])+    where+    collectSkolems :: Type -> [SkolemScope]+    collectSkolems = nub . everythingOnTypes (++) collect+      where+      collect (Skolem _ _ scope) = [scope]+      collect _ = []+  go scos _ = (scos, [])+  findBindingScope :: SkolemScope -> Maybe Expr+  findBindingScope sco =+    let (_, f, _, _, _) = everythingOnValues mappend (const mempty) go' (const mempty) (const mempty) (const mempty)+    in getFirst $ f root+    where+    go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = First (Just val)+    go' _ = mempty+skolemEscapeCheck val = throwError $ mkErrorStack "Untyped value passed to skolemEscapeCheck" (Just (ExprError val))

@@ -0,0 +1,103 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.TypeChecker.Subsumption+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- Subsumption checking+--+-----------------------------------------------------------------------------++module Language.PureScript.TypeChecker.Subsumption (+    subsumes+) where++import Data.List (sortBy)+import Data.Monoid+import Data.Ord (comparing)++import Control.Applicative+import Control.Monad.Error+import Control.Monad.Unify++import Language.PureScript.AST+import Language.PureScript.Environment+import Language.PureScript.Errors+import Language.PureScript.Pretty+import Language.PureScript.TypeChecker.Monad+import Language.PureScript.TypeChecker.Skolems+import Language.PureScript.TypeChecker.Synonyms+import Language.PureScript.TypeChecker.Unify+import Language.PureScript.Types++-- |+-- Check whether one type subsumes another, rethrowing errors to provide a better error message+--+subsumes :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr)+subsumes val ty1 ty2 = rethrow (mkErrorStack errorMessage (ExprError <$> val) <>) $ subsumes' val ty1 ty2+  where+  errorMessage = "Error checking that type "+    ++ prettyPrintType ty1+    ++ " subsumes type "+    ++ prettyPrintType ty2++-- |+-- Check whether one type subsumes another+--+subsumes' :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr)+subsumes' val (ForAll ident ty1 _) ty2 = do+  replaced <- replaceVarWithUnknown ident ty1+  subsumes val replaced ty2+subsumes' val ty1 (ForAll ident ty2 sco) =+  case sco of+    Just sco' -> do+      sko <- newSkolemConstant+      let sk = skolemize ident sko sco' ty2+      subsumes val ty1 sk+    Nothing -> throwError . strMsg $ "Skolem variable scope is unspecified"+subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do+  _ <- subsumes Nothing arg2 arg1+  _ <- subsumes Nothing ret1 ret2+  return val+subsumes' val (SaturatedTypeSynonym name tyArgs) ty2 = do+  ty1 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs+  subsumes val ty1 ty2+subsumes' val ty1 (SaturatedTypeSynonym name tyArgs) = do+  ty2 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs+  subsumes val ty1 ty2+subsumes' val (KindedType ty1 _) ty2 =+  subsumes val ty1 ty2+subsumes' val ty1 (KindedType ty2 _) =+  subsumes val ty1 ty2+subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do+  dicts <- getTypeClassDictionaries+  subsumes' (Just $ foldl App val (map (flip (TypeClassDictionary True) dicts) constraints)) ty1 ty2+subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyObject && f2 == tyObject = do+  let+    (ts1, r1') = rowToList r1+    (ts2, r2') = rowToList r2+    ts1' = sortBy (comparing fst) ts1+    ts2' = sortBy (comparing fst) ts2+  go ts1' ts2' r1' r2'+  return val+  where+  go [] ts2 r1' r2' = r1' =?= rowFromList (ts2, r2')+  go ts1 [] r1' r2' = r2' =?= rowFromList (ts1, r1')+  go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1' r2'+    | p1 == p2 = do _ <- subsumes Nothing ty1 ty2+                    go ts1 ts2 r1' r2'+    | p1 < p2 = do rest <- fresh+                   r2' =?= RCons p1 ty1 rest+                   go ts1 ((p2, ty2) : ts2) r1' rest+    | otherwise = do rest <- fresh+                     r1' =?= RCons p2 ty2 rest+                     go ((p1, ty1) : ts1) ts2 rest r2'+subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyObject = subsumes val ty2 ty1+subsumes' val ty1 ty2 = do+  ty1 =?= ty2+  return val

@@ -13,18 +13,29 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}+ module Language.PureScript.TypeChecker.Synonyms (-    saturateAllTypeSynonyms+    saturateAllTypeSynonyms,+    desaturateAllTypeSynonyms,+    replaceAllTypeSynonyms,+    expandAllTypeSynonyms,+    expandTypeSynonym,+    expandTypeSynonym' ) where -import Language.PureScript.Types-import Language.PureScript.Names--import Control.Applicative ((<$>)) import Data.Maybe (fromMaybe)-import Control.Monad.Writer+import qualified Data.Map as M++import Control.Applicative import Control.Monad.Error+import Control.Monad.State +import Language.PureScript.Environment+import Language.PureScript.Names+import Language.PureScript.TypeChecker.Monad+import Language.PureScript.Types+ -- | -- Build a type substitution for a type synonym --@@ -51,5 +62,49 @@ saturateAllTypeSynonyms :: [(Qualified ProperName, Int)] -> Type -> Either String Type saturateAllTypeSynonyms syns d = foldM (\result (name, n) -> saturateTypeSynonym name n result) d syns +-- |+-- \"Desaturate\" @SaturatedTypeSynonym@s+--+desaturateAllTypeSynonyms :: Type -> Type+desaturateAllTypeSynonyms = everywhereOnTypes replaceSaturatedTypeSynonym+  where+  replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args+  replaceSaturatedTypeSynonym t = t +-- |+-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate+-- better error messages during unification.+--+replaceAllTypeSynonyms' :: Environment -> Type -> Either String Type+replaceAllTypeSynonyms' env d =+  let+    syns = map (\(name, (args, _)) -> (name, length args)) . M.toList $ typeSynonyms env+  in+    saturateAllTypeSynonyms syns d +replaceAllTypeSynonyms :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type+replaceAllTypeSynonyms d = do+  env <- getEnv+  either (throwError . strMsg) return $ replaceAllTypeSynonyms' env d++-- |+-- Replace a type synonym and its arguments with the aliased type+--+expandTypeSynonym' :: Environment -> Qualified ProperName -> [Type] -> Either String Type+expandTypeSynonym' env name args =+  case M.lookup name (typeSynonyms env) of+    Just (synArgs, body) -> do+      let repl = replaceAllTypeVars (zip (map fst synArgs) args) body+      replaceAllTypeSynonyms' env repl+    Nothing -> error "Type synonym was not defined"++expandTypeSynonym :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type+expandTypeSynonym name args = do+  env <- getEnv+  either (throwError . strMsg) return $ expandTypeSynonym' env name args++expandAllTypeSynonyms :: (Error e, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type+expandAllTypeSynonyms = everywhereOnTypesTopDownM go+  where+  go (SaturatedTypeSynonym name args) = expandTypeSynonym name args+  go other = return other

@@ -13,10 +13,7 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}  module Language.PureScript.TypeChecker.Types (     typesOf@@ -36,138 +33,38 @@      checkFunctionApplication       Check a function of a given type returns a value of another type when applied to its arguments--    subsumes-      Check a type subsumes another type -} +import Data.Either (lefts, rights) import Data.List-import Data.Maybe (maybeToList, fromMaybe)-import Data.Function (on)-import Data.Ord (comparing)+import Data.Maybe (fromMaybe) import Data.Monoid-import Data.Either (lefts, rights)+import qualified Data.Map as M -import Language.PureScript.Declarations-import Language.PureScript.Types+import Control.Applicative+import Control.Monad.Error+import Control.Monad.State+import Control.Monad.Unify++import Language.PureScript.AST+import Language.PureScript.Environment+import Language.PureScript.Errors import Language.PureScript.Kinds import Language.PureScript.Names-import Language.PureScript.TypeClassDictionaries-import Language.PureScript.TypeChecker.Monad+import Language.PureScript.Pretty+import Language.PureScript.TypeChecker.Entailment import Language.PureScript.TypeChecker.Kinds+import Language.PureScript.TypeChecker.Monad+import Language.PureScript.TypeChecker.Rows+import Language.PureScript.TypeChecker.Skolems+import Language.PureScript.TypeChecker.Subsumption import Language.PureScript.TypeChecker.Synonyms-import Language.PureScript.Pretty-import Language.PureScript.Environment-import Language.PureScript.Errors+import Language.PureScript.TypeChecker.Unify+import Language.PureScript.TypeClassDictionaries+import Language.PureScript.Types import qualified Language.PureScript.Constants as C -import Control.Monad.State-import Control.Monad.Error-import Control.Monad.Unify--import Control.Applicative-import Control.Arrow (Arrow(..))--import qualified Data.Map as M-import qualified Data.HashMap.Strict as H--instance Partial Type where-  unknown = TUnknown-  isUnknown (TUnknown u) = Just u-  isUnknown _ = Nothing-  unknowns = everythingOnTypes (++) go-    where-    go (TUnknown u) = [u]-    go _ = []-  ($?) sub = everywhereOnTypes go-    where-    go t@(TUnknown u) = case H.lookup u (runSubstitution sub) of-                          Nothing -> t-                          Just t' -> t'-    go other = other--instance Unifiable Check Type where-  (=?=) = unifyTypes- -- |--- Unify two types, updating the current substitution----unifyTypes :: Type -> Type -> UnifyT Type Check ()-unifyTypes t1 t2 = rethrow (mkErrorStack ("Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2) Nothing <>) $-  unifyTypes' t1 t2-  where-  unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()-  unifyTypes' (TUnknown u) t = u =:= t-  unifyTypes' t (TUnknown u) = u =:= t-  unifyTypes' (SaturatedTypeSynonym name args) ty = do-    ty1 <- introduceSkolemScope <=< expandTypeSynonym name $ args-    ty1 `unifyTypes` ty-  unifyTypes' ty s@(SaturatedTypeSynonym _ _) = s `unifyTypes` ty-  unifyTypes' (ForAll ident1 ty1 sc1) (ForAll ident2 ty2 sc2) =-    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-        sk1 `unifyTypes` sk2-      _ -> error "Skolemized type variable was not given a scope"-  unifyTypes' (ForAll ident ty1 (Just sc)) ty2 = do-    sko <- newSkolemConstant-    let sk = skolemize ident sko sc ty1-    sk `unifyTypes` ty2-  unifyTypes' ForAll{} _ = throwError . strMsg $ "Skolem variable scope is unspecified"-  unifyTypes' ty f@ForAll{} = f `unifyTypes` ty-  unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()-  unifyTypes' (TypeConstructor c1) (TypeConstructor c2) =-    guardWith (strMsg ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".")) (c1 == c2)-  unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do-    t3 `unifyTypes` t5-    t4 `unifyTypes` t6-  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-  unifyTypes' r1 r2@RCons{} = unifyRows r1 r2-  unifyTypes' r1@REmpty r2 = unifyRows r1 r2-  unifyTypes' r1 r2@REmpty = unifyRows r1 r2-  unifyTypes' t@(ConstrainedType _ _) _ = throwError . strMsg $ "Attempted to unify a constrained type " ++ prettyPrintType t ++ " with another type."-  unifyTypes' t3 t4@(ConstrainedType _ _) = unifyTypes' t4 t3-  unifyTypes' t3 t4 = throwError . strMsg $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."---- |--- Unify two rows, updating the current substitution------ Common labels are first identified, and unified. Remaining labels and types are unified with a--- trailing row unification variable, if appropriate, otherwise leftover labels result in a unification--- error.----unifyRows :: Type -> Type -> UnifyT Type Check ()-unifyRows r1 r2 =-  let-    (s1, r1') = rowToList r1-    (s2, r2') = rowToList r2-    int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]-    sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]-    sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]-  in do-    forM_ int (uncurry (=?=))-    unifyRows' sd1 r1' sd2 r2'-  where-  unifyRows' :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> UnifyT Type Check ()-  unifyRows' [] (TUnknown u) sd r = u =:= rowFromList (sd, r)-  unifyRows' sd r [] (TUnknown u) = u =:= rowFromList (sd, r)-  unifyRows' sd1 (TUnknown u1) sd2 (TUnknown u2) = do-    forM_ sd1 $ \(_, t) -> occursCheck u2 t-    forM_ sd2 $ \(_, t) -> occursCheck u1 t-    rest <- fresh-    u1 =:= rowFromList (sd2, rest)-    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 . strMsg $ "Cannot unify (" ++ prettyPrintRow (rowFromList (sd3, r3)) ++ ") with (" ++ prettyPrintRow (rowFromList (sd4, r4)) ++ ")"---- | -- Infer the types of multiple mutually-recursive values, and return elaborated values including -- type class dictionaries and type annotations. --@@ -232,15 +129,17 @@  checkTypedBindingGroupElement :: ModuleName -> (Ident, (Expr, Type, Bool)) -> TypeData ->  UnifyT Type Check (Ident, (Expr, Type)) checkTypedBindingGroupElement moduleName (ident, (val', ty, checkType)) dict = do+  -- Replace type wildcards+  ty' <- replaceTypeWildcards ty   -- Kind check   kind <- liftCheck $ kindOf moduleName ty   guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star   -- Check the type with the new names in scope-  ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty+  ty'' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty'   val'' <- if checkType-           then bindNames dict $ TypedValue True <$> check val' ty' <*> pure ty'-           else return (TypedValue False val' ty')-  return (ident, (val'', ty'))+           then bindNames dict $ TypedValue True <$> check val' ty'' <*> pure ty''+           else return (TypedValue False val' ty'')+  return (ident, (val'', ty''))  typeForBindingGroupElement :: (Ident, Expr) -> TypeData -> UntypedData -> UnifyT Type Check (Ident, (Expr, Type)) typeForBindingGroupElement (ident, val) dict untypedDict = do@@ -252,7 +151,7 @@ -- | -- Check if a value contains a type annotation ---isTyped :: (Ident, Expr) -> (Either (Ident, Expr) (Ident, (Expr, Type, Bool)))+isTyped :: (Ident, Expr) -> Either (Ident, Expr) (Ident, (Expr, Type, Bool)) isTyped (name, TypedValue checkType value ty) = Right (name, (value, ty, checkType)) isTyped (name, value) = Left (name, value) @@ -281,291 +180,12 @@   go other = return other  -- |--- A simplified representation of expressions which are used to represent type--- class dictionaries at runtime, which can be compared for equality----data DictionaryValue-  -- |-  -- A dictionary which is brought into scope by a local constraint-  ---  = LocalDictionaryValue (Qualified Ident)-  -- |-  -- A dictionary which is brought into scope by an instance declaration-  ---  | GlobalDictionaryValue (Qualified Ident)-  -- |-  -- A dictionary which depends on other dictionaries-  ---  | DependentDictionaryValue (Qualified Ident) [DictionaryValue]-  -- |-  -- A subclass dictionary-  ---  | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer-  deriving (Show, Ord, Eq)---- |--- 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 :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Bool -> Check Expr-entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filter filterModule context))-  where-    sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v]-    sortedNubBy f vs = M.elems (M.fromList (map (f &&& id) vs))--    -- Filter out type dictionaries which are in scope in the current module-    filterModule :: TypeClassDictionaryInScope -> Bool-    filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True-    filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True-    filterModule _ = False--    solve context' (className, tys) trySuperclasses =-      checkOverlaps $ go trySuperclasses className tys-      where-      go trySuperclasses' className' tys' =-        -- Look for regular type instances-        [ mkDictionary (canonicalizeDictionary tcd) args-        | tcd <- context'-        -- Make sure the type class name matches the one we are trying to satisfy-        , className' == tcdClassName tcd-        -- Make sure the type unifies with the type in the type instance definition-        , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)-        -- Solve any necessary subgoals-        , args <- solveSubgoals subst (tcdDependencies tcd) ] ++-      -        -- Look for implementations via superclasses-        [ SubclassDictionaryValue suDict superclass index-        | trySuperclasses'-        , (subclassName, (args, _, implies)) <- M.toList (typeClasses env)-        -- Try each superclass-        , (index, (superclass, suTyArgs)) <- zip [0..] implies-        -- Make sure the type class name matches the superclass name-        , className' == superclass-        -- Make sure the types unify with the types in the superclass implication-        , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs-        -- Finally, satisfy the subclass constraint-        , args' <- maybeToList $ mapM (flip lookup subst) (map fst args)-        , suDict <- go True subclassName args' ]-      -      -- Create dictionaries for subgoals which still need to be solved by calling go recursively-      -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type-      -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.-      solveSubgoals :: [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [DictionaryValue]]-      solveSubgoals _ Nothing = return Nothing-      solveSubgoals subst (Just subgoals) = do-        dict <- mapM (uncurry (go True) . second (map (replaceAllTypeVars subst))) subgoals-        return $ Just dict-      -- Make a dictionary from subgoal dictionaries by applying the correct function-      mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue-      mkDictionary fnName Nothing = LocalDictionaryValue fnName-      mkDictionary fnName (Just []) = GlobalDictionaryValue fnName-      mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts-      -- Turn a DictionaryValue into a Expr-      dictionaryValueToValue :: DictionaryValue -> Expr-      dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName-      dictionaryValueToValue (GlobalDictionaryValue fnName) = Var fnName-      dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)-      dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) =-        App (Accessor (C.__superclass_ ++ show superclassName ++ "_" ++ show index)-                      (dictionaryValueToValue dict))-            valUndefined-      -- Ensure that a substitution is valid-      verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]-      verifySubstitution subst = do-        let grps = groupBy ((==) `on` fst) subst-        guard (all (pairwise (unifiesWith env) . map snd) grps)-        return $ map head grps-      -- |-      -- Check for overlapping instances-      ---      checkOverlaps :: [DictionaryValue] -> Check Expr    -      checkOverlaps dicts = -        case [ (d1, d2) | d1 <- dicts, d2 <- dicts, d1 `overlapping` d2 ] of-          (d1, d2) : _ -> throwError . strMsg $ unlines-            [ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintType tys) ++ "."-            , "For example:"-            , prettyPrintDictionaryValue d1-            , "and:"-            , prettyPrintDictionaryValue d2-            ]-          _ -> case chooseSimplestDictionaries dicts of-                 [] -> throwError . strMsg $ -                         "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)-                 d : _ -> return $ dictionaryValueToValue d-      -- Choose the simplest DictionaryValues from a list of candidates-      -- The reason for this function is as follows:-      -- When considering overlapping instances, we don't want to consider the same dictionary-      -- to be an overlap of itself when obtained as a superclass of another class.-      -- Observing that we probably don't want to select a superclass instance when an instance-      -- is available directly, and that there is no way for a superclass instance to actually-      -- introduce an overlap that wouldn't have been there already, we simply remove dictionaries-      -- obtained as superclass instances if there are simpler instances available.-      chooseSimplestDictionaries :: [DictionaryValue] -> [DictionaryValue]-      chooseSimplestDictionaries ds = case filter isSimpleDictionaryValue ds of-                                        [] -> ds-                                        simple -> simple-      isSimpleDictionaryValue SubclassDictionaryValue{} = False-      isSimpleDictionaryValue (DependentDictionaryValue _ ds) = all isSimpleDictionaryValue ds-      isSimpleDictionaryValue _ = True-      -- |-      -- Check if two dictionaries are overlapping-      -- -      -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have-      -- been caught when constructing superclass dictionaries.-      ---      overlapping :: DictionaryValue -> DictionaryValue -> Bool-      overlapping (LocalDictionaryValue nm1)         (LocalDictionaryValue nm2)  | nm1 == nm2 = False-      overlapping (GlobalDictionaryValue nm1)        (GlobalDictionaryValue nm2) | nm1 == nm2 = False-      overlapping (DependentDictionaryValue nm1 ds1) (DependentDictionaryValue nm2 ds2) -        | nm1 == nm2 = any id $ zipWith overlapping ds1 ds2-      overlapping (SubclassDictionaryValue _ _ _) _ = False-      overlapping _ (SubclassDictionaryValue _ _ _) = False-      overlapping _ _ = True-      -- |-      -- Render a DictionaryValue fit for human consumption in error messages-      ---      prettyPrintDictionaryValue :: DictionaryValue -> String-      prettyPrintDictionaryValue = unlines . indented 0-        where-        indented n (LocalDictionaryValue _)           = [spaces n ++ "Dictionary in scope"]-        indented n (GlobalDictionaryValue nm)         = [spaces n ++ show nm]-        indented n (DependentDictionaryValue nm args) = (spaces n ++ show nm ++ " via") : concatMap (indented (n + 2)) args-        indented n (SubclassDictionaryValue sup nm _) = (spaces n ++ show nm ++ " via superclass") : indented (n + 2) sup-        -        spaces n = replicate n ' ' ++ "- "--    valUndefined :: Expr-    valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))---- |--- Check all values in a list pairwise match a predicate----pairwise :: (a -> a -> Bool) -> [a] -> Bool-pairwise _ [] = True-pairwise _ [_] = True-pairwise p (x : xs) = all (p x) xs && pairwise p xs---- |--- Check that two types unify----unifiesWith :: Environment -> Type -> Type -> Bool-unifiesWith _ (TUnknown u1) (TUnknown u2) | u1 == u2 = 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 e (TypeApp h1 t1) (TypeApp h2 t2) = unifiesWith e h1 h2 && unifiesWith e t1 t2-unifiesWith e (SaturatedTypeSynonym name args) t2 =-  case expandTypeSynonym' e name args of-    Left  _  -> False-    Right t1 -> unifiesWith e t1 t2-unifiesWith e t1 t2@(SaturatedTypeSynonym _ _) = unifiesWith e t2 t1-unifiesWith _ _ _ = False---- |--- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup),--- and return a substitution from type variables to types which makes the type heads unify.----typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]-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 e (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m e h1 h2 <*> typeHeadsAreEqual m e t1 t2-typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e name args of-  Left  _  -> Nothing-  Right t1 -> typeHeadsAreEqual m e t1 t2-typeHeadsAreEqual _ _ _ _ = Nothing---- |--- Ensure skolem variables do not escape their scope----skolemEscapeCheck :: Expr -> Check ()-skolemEscapeCheck (TypedValue False _ _) = return ()-skolemEscapeCheck root@TypedValue{} =-  -- Every skolem variable is created when a ForAll type is skolemized.-  -- This determines the scope of that skolem variable, which is copied from the SkolemScope-  -- field of the ForAll constructor.-  -- We traverse the tree top-down, and collect any SkolemScopes introduced by ForAlls.-  -- If a Skolem is encountered whose SkolemScope is not in the current list, we have found-  -- an escaped skolem variable.-  let (_, f, _, _, _) = everythingWithContextOnValues [] [] (++) def go def def def-  in case f root of-       [] -> return ()-       ((binding, val) : _) -> throwError $ mkErrorStack ("Rigid/skolem type variable " ++ maybe "" (("bound by " ++) . prettyPrintValue) binding ++ " has escaped.") (Just (ExprError val))-  where-  def s _ = (s, [])--  go :: [(SkolemScope, Expr)] -> Expr -> ([(SkolemScope, Expr)], [(Maybe Expr, Expr)])-  go scos val@(TypedValue _ _ (ForAll _ _ (Just sco))) = ((sco, val) : scos, [])-  go scos val@(TypedValue _ _ ty) = case collectSkolems ty \\ map fst scos of-                                      (sco : _) -> (scos, [(findBindingScope sco, val)])-                                      _ -> (scos, [])-    where-    collectSkolems :: Type -> [SkolemScope]-    collectSkolems = nub . everythingOnTypes (++) collect-      where-      collect (Skolem _ _ scope) = [scope]-      collect _ = []-  go scos _ = (scos, [])-  findBindingScope :: SkolemScope -> Maybe Expr-  findBindingScope sco =-    let (_, f, _, _, _) = everythingOnValues mappend (const mempty) go' (const mempty) (const mempty) (const mempty)-    in getFirst $ f root-    where-    go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = First (Just val)-    go' _ = mempty-skolemEscapeCheck val = throwError $ mkErrorStack "Untyped value passed to skolemEscapeCheck" (Just (ExprError val))---- |--- Ensure rows do not contain duplicate labels----checkDuplicateLabels :: Expr -> Check ()-checkDuplicateLabels = -  let (_, f, _) = everywhereOnValuesM def go def -  in void . f-  where -  def :: a -> Check a-  def = return-   -  go :: Expr -> Check Expr-  go e@(TypedValue _ val ty) = do-    checkDups ty-    return e-    -    where-    checkDups :: Type -> Check ()-    checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2-    checkDups (SaturatedTypeSynonym _ ts) = mapM_ checkDups ts-    checkDups (ForAll _ t _) = checkDups t-    checkDups (ConstrainedType args t) = do-      mapM_ (checkDups) $ concatMap snd args-      checkDups t -    checkDups r@(RCons _ _ _) = -      let (ls, _) = rowToList r in -      case firstDup . sort . map fst $ ls of-        Just l -> throwError $ mkErrorStack ("Duplicate label " ++ show l ++ " in row") $ Just (ExprError val)-        Nothing -> return ()-    checkDups _ = return ()-  -    firstDup :: (Eq a) => [a] -> Maybe a-    firstDup (x : xs@(x' : _)) -      | x == x' = Just x-      | otherwise = firstDup xs-    firstDup _ = Nothing    -        -  go other = return other-  --- |--- Replace outermost unsolved unification variables with named type variables+-- Check the kind of a type, failing if it is not of kind *. ---varIfUnknown :: Type -> Type-varIfUnknown ty =-  let unks = nub $ unknowns ty-      toName = (:) 't' . show-      ty' = everywhereOnTypes typeToVar ty-      typeToVar :: Type -> Type-      typeToVar (TUnknown u) = TypeVar (toName u)-      typeToVar t = t-  in mkForAll (sort . map toName $ unks) ty'+checkTypeKind :: ModuleName -> Type -> UnifyT t Check ()+checkTypeKind moduleName ty = do+  kind <- liftCheck $ kindOf moduleName ty+  guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star  -- | -- Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns@@ -585,67 +205,6 @@ instantiatePolyTypeWithUnknowns val ty = return (val, ty)  -- |--- Replace a single type variable with a new unification variable----replaceVarWithUnknown :: String -> Type -> UnifyT Type Check Type-replaceVarWithUnknown ident ty = do-  tu <- fresh-  return $ replaceTypeVars ident tu ty---- |--- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate--- better error messages during unification.----replaceAllTypeSynonyms' :: Environment -> Type -> Either String Type-replaceAllTypeSynonyms' env d =-  let-    syns = map (\(name, (args, _)) -> (name, length args)) . M.toList $ typeSynonyms env-  in-    saturateAllTypeSynonyms syns d--replaceAllTypeSynonyms :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type-replaceAllTypeSynonyms d = do-  env <- getEnv-  either (throwError . strMsg) return $ replaceAllTypeSynonyms' env d---- |--- \"Desaturate\" @SaturatedTypeSynonym@s----desaturateAllTypeSynonyms :: Type -> Type-desaturateAllTypeSynonyms = everywhereOnTypes replaceSaturatedTypeSynonym-  where-  replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args-  replaceSaturatedTypeSynonym t = t---- |--- Replace a type synonym and its arguments with the aliased type----expandTypeSynonym' :: Environment -> Qualified ProperName -> [Type] -> Either String Type-expandTypeSynonym' env name args =-  case M.lookup name (typeSynonyms env) of-    Just (synArgs, body) -> do-      let repl = replaceAllTypeVars (zip (map fst synArgs) args) body-      replaceAllTypeSynonyms' env repl-    Nothing -> error "Type synonym was not defined"--expandTypeSynonym :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type-expandTypeSynonym name args = do-  env <- getEnv-  either (throwError . strMsg) return $ expandTypeSynonym' env name args--expandAllTypeSynonyms :: (Error e, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type-expandAllTypeSynonyms = everywhereOnTypesTopDownM go-  where-  go (SaturatedTypeSynonym name args) = expandTypeSynonym name args-  go other = return other---- |--- Ensure a set of property names and value does not contain duplicate labels----ensureNoDuplicateProperties :: (Error e, MonadError e m) => [(String, Expr)] -> m ()-ensureNoDuplicateProperties ps = guardWith (strMsg "Duplicate property names") $ length (nub . map fst $ ps) == length ps---- | -- Infer a type for a value, rethrowing any error to provide a more useful error message -- infer :: Expr -> UnifyT Type Check Expr@@ -702,7 +261,7 @@ infer' (Var var) = do   Just moduleName <- checkCurrentModule <$> get   checkVisibility moduleName var-  ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var+  ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards <=< lookupVariable moduleName $ var   case ty of     ConstrainedType constraints ty' -> do       dicts <- getTypeClassDictionaries@@ -733,9 +292,8 @@   return $ TypeClassDictionary False (className, tys) dicts infer' (TypedValue checkType val ty) = do   Just moduleName <- checkCurrentModule <$> get-  kind <- liftCheck $ kindOf moduleName ty-  guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star-  ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty+  checkTypeKind moduleName ty+  ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty   val' <- if checkType then check val ty' else return val   return $ TypedValue True val' ty' infer' (PositionedValue pos val) = rethrowWithPosition pos $ infer' val@@ -743,21 +301,20 @@  inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Type Check Expr) -> UnifyT Type Check ([Declaration], Expr) inferLetBinding seen [] ret j = (,) seen <$> makeBindingGroupVisible (j ret)-inferLetBinding seen (ValueDeclaration ident nameKind [] Nothing tv@(TypedValue checkType val ty) : rest) ret j = do+inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue checkType val ty))) : rest) ret j = do   Just moduleName <- checkCurrentModule <$> get-  kind <- liftCheck $ kindOf moduleName ty-  guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star+  checkTypeKind moduleName ty   let dict = M.singleton (moduleName, ident) (ty, nameKind, Undefined)-  ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty+  ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty   TypedValue _ val' ty'' <- if checkType then bindNames dict (check val ty') else return tv-  bindNames (M.singleton (moduleName, ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing (TypedValue checkType val' ty'')]) rest ret j-inferLetBinding seen (ValueDeclaration ident nameKind [] Nothing val : rest) ret j = do+  bindNames (M.singleton (moduleName, ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right (TypedValue checkType val' ty''))]) rest ret j+inferLetBinding seen (ValueDeclaration ident nameKind [] (Right val) : rest) ret j = do   valTy <- fresh   Just moduleName <- checkCurrentModule <$> get   let dict = M.singleton (moduleName, ident) (valTy, nameKind, Undefined)   TypedValue _ val' valTy' <- bindNames dict $ infer val   valTy =?= valTy'-  bindNames (M.singleton (moduleName, ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing val']) rest ret j+  bindNames (M.singleton (moduleName, ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right val')]) rest ret j inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do   Just moduleName <- checkCurrentModule <$> get   (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)@@ -766,7 +323,7 @@   let ds' = [(ident, LocalVariable, val') | (ident, (val', _)) <- ds1' ++ ds2']   makeBindingGroupVisible $ bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j inferLetBinding seen (PositionedDeclaration pos d : ds) ret j = rethrowWithPosition pos $ do-  ((d' : ds'), val') <- inferLetBinding seen (d : ds) ret j+  (d' : ds', val') <- inferLetBinding seen (d : ds) ret j   return (PositionedDeclaration pos d' : ds', val') inferLetBinding _ _ _ _ = error "Invalid argument to inferLetBinding" @@ -845,60 +402,27 @@ -- checkBinders :: [Type] -> Type -> [CaseAlternative] -> UnifyT Type Check [CaseAlternative] checkBinders _ _ [] = return []-checkBinders nvals ret (CaseAlternative binders grd val : bs) = do+checkBinders nvals ret (CaseAlternative binders result : bs) = do   guardWith (strMsg "Overlapping binders in case statement") $     let ns = concatMap binderNames binders in length (nub ns) == length ns   Just moduleName <- checkCurrentModule <$> get   m1 <- M.unions <$> zipWithM inferBinder nvals binders-  r <- bindLocalVariables moduleName [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $ do-    val' <- TypedValue True <$> check val ret <*> pure ret-    case grd of-      Nothing -> return $ CaseAlternative binders Nothing val'-      Just g -> do-        g' <- check g tyBoolean-        return $ CaseAlternative binders (Just g') val'+  r <- bindLocalVariables moduleName [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $+    CaseAlternative binders <$>+      case result of+        Left gs -> do+          gs' <- forM gs $ \(grd, val) -> do+            grd' <- check grd tyBoolean+            val' <- TypedValue True <$> check val ret <*> pure ret+            return (grd', val')+          return $ Left gs'+        Right val -> do+          val' <- TypedValue True <$> check val ret <*> pure ret+          return $ Right val'   rs <- checkBinders nvals ret bs   return $ r : rs  -- |--- Generate a new skolem constant----newSkolemConstant :: UnifyT Type Check Int-newSkolemConstant = fresh'---- |--- Generate a new skolem scope----newSkolemScope :: UnifyT Type Check SkolemScope-newSkolemScope = SkolemScope <$> fresh'---- |--- 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)---- |--- 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 = let (_, f, _) = everywhereOnValues id go id in f-  where-  go (SuperClassDictionary c ts) = SuperClassDictionary c (map (skolemize ident sko scope) ts)-  go other = other---- |--- Introduce skolem scope at every occurence of a ForAll----introduceSkolemScope :: Type -> UnifyT Type Check Type-introduceSkolemScope = everywhereOnTypesM go-  where-  go (ForAll ident ty Nothing) = ForAll ident ty <$> (Just <$> newSkolemScope)-  go other = return other---- | -- Check the type of a value, rethrowing errors to provide a better error message -- check :: Expr -> Type -> UnifyT Type Check Expr@@ -961,7 +485,7 @@   Just moduleName <- checkCurrentModule <$> get   checkVisibility moduleName var   repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var-  ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty+  ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty   v' <- subsumes (Just v) repl ty'   case v' of     Nothing -> throwError . strMsg $ "Unable to check type subsumption"@@ -981,10 +505,9 @@   return $ TypeClassDictionary False (className, tys) dicts check' (TypedValue checkType val ty1) ty2 = do   Just moduleName <- checkCurrentModule <$> get-  kind <- liftCheck $ kindOf moduleName ty1-  guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star-  ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1-  ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty2+  checkTypeKind moduleName ty1+  ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty1+  ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2   val' <- subsumes (Just val) ty1' ty2'   case val' of     Nothing -> throwError . strMsg $ "Unable to check type subsumption"@@ -1031,10 +554,10 @@       _ <- subsumes Nothing repl ty       return $ TypedValue True (Constructor c) ty check' (Let ds val) ty = do-  (ds', val') <- inferLetBinding [] ds val (flip check ty)+  (ds', val') <- inferLetBinding [] ds val (`check` ty)   return $ TypedValue True (Let ds' val') ty check' val ty | containsTypeSynonyms ty = do-  ty' <- introduceSkolemScope <=< expandAllTypeSynonyms $ ty+  ty' <- introduceSkolemScope <=< expandAllTypeSynonyms <=< replaceTypeWildcards $ ty   check val ty' check' val kt@(KindedType ty kind) = do   guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star@@ -1059,7 +582,7 @@   go [] [] REmpty = return []   go [] [] u@(TUnknown _) = do u =?= REmpty                                return []-  go [] [] (Skolem _ _ _) | lax = return []+  go [] [] Skolem{} | lax = return []   go [] ((p, _): _) _ | lax = return []                       | otherwise = throwError $ mkErrorStack ("Object does not have property " ++ p) (Just (ExprError (ObjectLiteral ps)))   go ((p,_):_) [] REmpty = throwError $ mkErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ExprError (ObjectLiteral ps)))@@ -1122,85 +645,18 @@ checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg ret = do   ty <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs   checkFunctionApplication fn ty arg ret-checkFunctionApplication' fn (KindedType ty _) arg ret = do+checkFunctionApplication' fn (KindedType ty _) arg ret =   checkFunctionApplication fn ty arg ret checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do   dicts <- getTypeClassDictionaries   checkFunctionApplication' (foldl App fn (map (flip (TypeClassDictionary True) dicts) constraints)) fnTy arg ret-checkFunctionApplication' fn fnTy dict@(TypeClassDictionary _ _ _) _ =+checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} _ =   return (fnTy, App fn dict) checkFunctionApplication' _ fnTy arg _ = throwError . strMsg $ "Cannot apply a function of type "   ++ prettyPrintType fnTy   ++ " to argument " ++ prettyPrintValue arg  -- |--- Check whether one type subsumes another, rethrowing errors to provide a better error message----subsumes :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr)-subsumes val ty1 ty2 = rethrow (mkErrorStack errorMessage (ExprError <$> val) <>) $ subsumes' val ty1 ty2-  where-  errorMessage = "Error checking that type "-    ++ prettyPrintType ty1-    ++ " subsumes type "-    ++ prettyPrintType ty2---- |--- Check whether one type subsumes another----subsumes' :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr)-subsumes' val (ForAll ident ty1 _) ty2 = do-  replaced <- replaceVarWithUnknown ident ty1-  subsumes val replaced ty2-subsumes' val ty1 (ForAll ident ty2 sco) =-  case sco of-    Just sco' -> do-      sko <- newSkolemConstant-      let sk = skolemize ident sko sco' ty2-      subsumes val ty1 sk-    Nothing -> throwError . strMsg $ "Skolem variable scope is unspecified"-subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do-  _ <- subsumes Nothing arg2 arg1-  _ <- subsumes Nothing ret1 ret2-  return val-subsumes' val (SaturatedTypeSynonym name tyArgs) ty2 = do-  ty1 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs-  subsumes val ty1 ty2-subsumes' val ty1 (SaturatedTypeSynonym name tyArgs) = do-  ty2 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs-  subsumes val ty1 ty2-subsumes' val (KindedType ty1 _) ty2 = do-  subsumes val ty1 ty2-subsumes' val ty1 (KindedType ty2 _) = do-  subsumes val ty1 ty2-subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do-  dicts <- getTypeClassDictionaries-  subsumes' (Just $ foldl App val (map (flip (TypeClassDictionary True) dicts) constraints)) ty1 ty2-subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyObject && f2 == tyObject = do-  let-    (ts1, r1') = rowToList r1-    (ts2, r2') = rowToList r2-    ts1' = sortBy (comparing fst) ts1-    ts2' = sortBy (comparing fst) ts2-  go ts1' ts2' r1' r2'-  return val-  where-  go [] ts2 r1' r2' = r1' =?= rowFromList (ts2, r2')-  go ts1 [] r1' r2' = r2' =?= rowFromList (ts1, r1')-  go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1' r2'-    | p1 == p2 = do _ <- subsumes Nothing ty1 ty2-                    go ts1 ts2 r1' r2'-    | p1 < p2 = do rest <- fresh-                   r2' =?= RCons p1 ty1 rest-                   go ts1 ((p2, ty2) : ts2) r1' rest-    | otherwise = do rest <- fresh-                     r1' =?= RCons p2 ty2 rest-                     go ((p1, ty1) : ts1) ts2 rest r2'-subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyObject = subsumes val ty2 ty1-subsumes' val ty1 ty2 = do-  ty1 =?= ty2-  return val---- | -- Compute the meet of two types, i.e. the most general type which both types subsume. -- TODO: handle constrained types --@@ -1215,9 +671,8 @@   t1 =?= t2   return (e1, e2, t1) ------+-- |+-- Ensure a set of property names and value does not contain duplicate labels+--+ensureNoDuplicateProperties :: (Error e, MonadError e m) => [(String, Expr)] -> m ()+ensureNoDuplicateProperties ps = guardWith (strMsg "Duplicate property names") $ length (nub . map fst $ ps) == length ps

@@ -0,0 +1,184 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.TypeChecker.Unify+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- Functions and instances relating to unification+--+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-}++module Language.PureScript.TypeChecker.Unify (+    unifyTypes,+    unifyRows,+    unifiesWith,+    replaceVarWithUnknown,+    replaceTypeWildcards,+    varIfUnknown+) where++import Data.List (nub, sort)+import Data.Maybe (fromMaybe)+import Data.Monoid+import qualified Data.HashMap.Strict as H++import Control.Monad.Error+import Control.Monad.Unify++import Language.PureScript.Environment+import Language.PureScript.Errors+import Language.PureScript.Pretty+import Language.PureScript.TypeChecker.Monad+import Language.PureScript.TypeChecker.Skolems+import Language.PureScript.TypeChecker.Synonyms+import Language.PureScript.Types++instance Partial Type where+  unknown = TUnknown+  isUnknown (TUnknown u) = Just u+  isUnknown _ = Nothing+  unknowns = everythingOnTypes (++) go+    where+    go (TUnknown u) = [u]+    go _ = []+  ($?) sub = everywhereOnTypes go+    where+    go t@(TUnknown u) = fromMaybe t $ H.lookup u (runSubstitution sub)+    go other = other++instance Unifiable Check Type where+  (=?=) = unifyTypes++-- |+-- Unify two types, updating the current substitution+--+unifyTypes :: Type -> Type -> UnifyT Type Check ()+unifyTypes t1 t2 = rethrow (mkErrorStack ("Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2) Nothing <>) $+  unifyTypes' t1 t2+  where+  unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()+  unifyTypes' (TUnknown u) t = u =:= t+  unifyTypes' t (TUnknown u) = u =:= t+  unifyTypes' (SaturatedTypeSynonym name args) ty = do+    ty1 <- introduceSkolemScope <=< expandTypeSynonym name $ args+    ty1 `unifyTypes` ty+  unifyTypes' ty s@(SaturatedTypeSynonym _ _) = s `unifyTypes` ty+  unifyTypes' (ForAll ident1 ty1 sc1) (ForAll ident2 ty2 sc2) =+    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+        sk1 `unifyTypes` sk2+      _ -> error "Skolemized type variable was not given a scope"+  unifyTypes' (ForAll ident ty1 (Just sc)) ty2 = do+    sko <- newSkolemConstant+    let sk = skolemize ident sko sc ty1+    sk `unifyTypes` ty2+  unifyTypes' ForAll{} _ = throwError . strMsg $ "Skolem variable scope is unspecified"+  unifyTypes' ty f@ForAll{} = f `unifyTypes` ty+  unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()+  unifyTypes' (TypeConstructor c1) (TypeConstructor c2) =+    guardWith (strMsg ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".")) (c1 == c2)+  unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do+    t3 `unifyTypes` t5+    t4 `unifyTypes` t6+  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+  unifyTypes' r1 r2@RCons{} = unifyRows r1 r2+  unifyTypes' r1@REmpty r2 = unifyRows r1 r2+  unifyTypes' r1 r2@REmpty = unifyRows r1 r2+  unifyTypes' t@(ConstrainedType _ _) _ = throwError . strMsg $ "Attempted to unify a constrained type " ++ prettyPrintType t ++ " with another type."+  unifyTypes' t3 t4@(ConstrainedType _ _) = unifyTypes' t4 t3+  unifyTypes' t3 t4 = throwError . strMsg $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."++-- |+-- Unify two rows, updating the current substitution+--+-- Common labels are first identified, and unified. Remaining labels and types are unified with a+-- trailing row unification variable, if appropriate, otherwise leftover labels result in a unification+-- error.+--+unifyRows :: Type -> Type -> UnifyT Type Check ()+unifyRows r1 r2 =+  let+    (s1, r1') = rowToList r1+    (s2, r2') = rowToList r2+    int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]+    sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]+    sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]+  in do+    forM_ int (uncurry (=?=))+    unifyRows' sd1 r1' sd2 r2'+  where+  unifyRows' :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> UnifyT Type Check ()+  unifyRows' [] (TUnknown u) sd r = u =:= rowFromList (sd, r)+  unifyRows' sd r [] (TUnknown u) = u =:= rowFromList (sd, r)+  unifyRows' sd1 (TUnknown u1) sd2 (TUnknown u2) = do+    forM_ sd1 $ \(_, t) -> occursCheck u2 t+    forM_ sd2 $ \(_, t) -> occursCheck u1 t+    rest <- fresh+    u1 =:= rowFromList (sd2, rest)+    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 . strMsg $ "Cannot unify (" ++ prettyPrintRow (rowFromList (sd3, r3)) ++ ") with (" ++ prettyPrintRow (rowFromList (sd4, r4)) ++ ")"++-- |+-- Check that two types unify+--+unifiesWith :: Environment -> Type -> Type -> Bool+unifiesWith _ (TUnknown u1) (TUnknown u2) | u1 == u2 = 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 e (TypeApp h1 t1) (TypeApp h2 t2) = unifiesWith e h1 h2 && unifiesWith e t1 t2+unifiesWith e (SaturatedTypeSynonym name args) t2 =+  case expandTypeSynonym' e name args of+    Left  _  -> False+    Right t1 -> unifiesWith e t1 t2+unifiesWith e t1 t2@(SaturatedTypeSynonym _ _) = unifiesWith e t2 t1+unifiesWith _ _ _ = False++-- |+-- Replace a single type variable with a new unification variable+--+replaceVarWithUnknown :: String -> Type -> UnifyT Type Check Type+replaceVarWithUnknown ident ty = do+  tu <- fresh+  return $ replaceTypeVars ident tu ty+  +-- |+-- Replace type wildcards with unknowns+--+replaceTypeWildcards :: Type -> UnifyT t Check Type+replaceTypeWildcards = everywhereOnTypesM replace+  where+  replace TypeWildcard = do+    u <- fresh'+    return $ TUnknown u+  replace other = return other++-- |+-- Replace outermost unsolved unification variables with named type variables+--+varIfUnknown :: Type -> Type+varIfUnknown ty =+  let unks = nub $ unknowns ty+      toName = (:) 't' . show+      ty' = everywhereOnTypes typeToVar ty+      typeToVar :: Type -> Type+      typeToVar (TUnknown u) = TypeVar (toName u)+      typeToVar t = t+  in mkForAll (sort . map toName $ unks) ty'

@@ -64,3 +64,10 @@   -- A type class dictionary which is an alias for an imported dictionary from another module   --   | TCDAlias (Qualified Ident) deriving (Show, Eq, Data, Typeable)++-- |+-- Find the original dictionary which a type class dictionary in scope refers to+--+canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident+canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm+canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm

@@ -47,6 +47,10 @@   --   | TypeVar String   -- |+  -- A type wildcard, as would appear in a partial type synonym+  --+  | TypeWildcard+  -- |   -- A type constructor   --   | TypeConstructor (Qualified ProperName)@@ -214,6 +218,16 @@     in case qs of          [] -> constrained          qs' -> foldl (\ty' (q, sco) -> ForAll q ty' sco) constrained qs'++-- |+-- Check if a type contains wildcards+--+containsWildcards :: Type -> Bool+containsWildcards = everythingOnTypes (||) go+  where+  go :: Type -> Bool+  go TypeWildcard = True+  go _ = False  -- -- Traversals