summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-11-18 00:47:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-11-18 00:47:00 (GMT)
commitf12ebae7a4a7e9911b9efc36b2205fd173df4f05 (patch)
tree1c555c2af442b2beef1f5fb99d3264e4ba9e63df
parent254c97a5f26fdaf5d48b5b79024f1056703f32b7 (diff)
version 0.6.10.6.1
-rw-r--r--examples/failing/TypeWildcards1.purs4
-rw-r--r--examples/failing/TypeWildcards2.purs4
-rw-r--r--examples/failing/TypeWildcards3.purs7
-rw-r--r--examples/passing/Guards.purs11
-rw-r--r--examples/passing/ImplicitEmptyImport.purs6
-rw-r--r--examples/passing/ReservedWords.purs13
-rw-r--r--examples/passing/TypeWildcards.purs13
-rw-r--r--prelude/prelude.purs12
-rw-r--r--psci/Main.hs79
-rw-r--r--purescript.cabal80
-rw-r--r--src/Language/PureScript.hs6
-rw-r--r--src/Language/PureScript/AST.hs23
-rw-r--r--src/Language/PureScript/AST/Binders.hs86
-rw-r--r--src/Language/PureScript/AST/Declarations.hs362
-rw-r--r--src/Language/PureScript/AST/Operators.hs39
-rw-r--r--src/Language/PureScript/AST/SourcePos.hs40
-rw-r--r--src/Language/PureScript/AST/Traversals.hs (renamed from src/Language/PureScript/Declarations.hs)570
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs6
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs30
-rw-r--r--src/Language/PureScript/Constants.hs3
-rw-r--r--src/Language/PureScript/DeadCodeElimination.hs8
-rw-r--r--src/Language/PureScript/Errors.hs2
-rw-r--r--src/Language/PureScript/ModuleDependencies.hs2
-rw-r--r--src/Language/PureScript/Parser/Common.hs6
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs65
-rw-r--r--src/Language/PureScript/Parser/Types.hs16
-rw-r--r--src/Language/PureScript/Pretty/Types.hs1
-rw-r--r--src/Language/PureScript/Pretty/Values.hs22
-rw-r--r--src/Language/PureScript/Renamer.hs13
-rw-r--r--src/Language/PureScript/Sugar.hs2
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs18
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs33
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs4
-rw-r--r--src/Language/PureScript/Sugar/Names.hs30
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs2
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs12
-rw-r--r--src/Language/PureScript/Sugar/TypeDeclarations.hs13
-rw-r--r--src/Language/PureScript/Traversals.hs7
-rw-r--r--src/Language/PureScript/TypeChecker.hs16
-rw-r--r--src/Language/PureScript/TypeChecker/Entailment.hs217
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs42
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs20
-rw-r--r--src/Language/PureScript/TypeChecker/Rows.hs66
-rw-r--r--src/Language/PureScript/TypeChecker/Skolems.hs114
-rw-r--r--src/Language/PureScript/TypeChecker/Subsumption.hs103
-rw-r--r--src/Language/PureScript/TypeChecker/Synonyms.hs67
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs685
-rw-r--r--src/Language/PureScript/TypeChecker/Unify.hs184
-rw-r--r--src/Language/PureScript/TypeClassDictionaries.hs7
-rw-r--r--src/Language/PureScript/Types.hs14
50 files changed, 1821 insertions, 1364 deletions
diff --git a/examples/failing/TypeWildcards1.purs b/examples/failing/TypeWildcards1.purs
new file mode 100644
index 0000000..b367fc6
--- /dev/null
+++ b/examples/failing/TypeWildcards1.purs
@@ -0,0 +1,4 @@
+module TypeWildcards where
+
+type Test = _
+
diff --git a/examples/failing/TypeWildcards2.purs b/examples/failing/TypeWildcards2.purs
new file mode 100644
index 0000000..a7546d6
--- /dev/null
+++ b/examples/failing/TypeWildcards2.purs
@@ -0,0 +1,4 @@
+module TypeWildcards where
+
+data Test = Test _
+
diff --git a/examples/failing/TypeWildcards3.purs b/examples/failing/TypeWildcards3.purs
new file mode 100644
index 0000000..7922d05
--- /dev/null
+++ b/examples/failing/TypeWildcards3.purs
@@ -0,0 +1,7 @@
+module TypeWildcards where
+
+data Foo a = Foo
+
+instance showFoo :: Show (Foo _) where
+ show Foo = "Foo"
+
diff --git a/examples/passing/Guards.purs b/examples/passing/Guards.purs
index a3e4662..1dce0f1 100644
--- a/examples/passing/Guards.purs
+++ b/examples/passing/Guards.purs
@@ -11,4 +11,13 @@ module Main where
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"
diff --git a/examples/passing/ImplicitEmptyImport.purs b/examples/passing/ImplicitEmptyImport.purs
new file mode 100644
index 0000000..3f68a77
--- /dev/null
+++ b/examples/passing/ImplicitEmptyImport.purs
@@ -0,0 +1,6 @@
+module Main where
+
+main = do
+ Debug.Trace.trace "Hello"
+ Debug.Trace.trace "Goodbye"
+ Debug.Trace.trace "Done"
diff --git a/examples/passing/ReservedWords.purs b/examples/passing/ReservedWords.purs
new file mode 100644
index 0000000..3a8be2e
--- /dev/null
+++ b/examples/passing/ReservedWords.purs
@@ -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" }
diff --git a/examples/passing/TypeWildcards.purs b/examples/passing/TypeWildcards.purs
new file mode 100644
index 0000000..cdfd7f1
--- /dev/null
+++ b/examples/passing/TypeWildcards.purs
@@ -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"
diff --git a/prelude/prelude.purs b/prelude/prelude.purs
index 8a4d317..65c37c5 100644
--- a/prelude/prelude.purs
+++ b/prelude/prelude.purs
@@ -1,5 +1,6 @@
module Prelude
- ( flip
+ ( otherwise
+ , flip
, const
, asTypeOf
, Semigroupoid, (<<<), (>>>)
@@ -7,7 +8,7 @@ module Prelude
, ($), (#)
, (:), cons
, Show, show
- , Functor, (<$>), void
+ , Functor, (<$>), (<#>), void
, Apply, (<*>)
, Applicative, pure, liftA1
, Bind, (>>=)
@@ -23,6 +24,9 @@ module Prelude
, 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,10 +115,14 @@ module Prelude
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
diff --git a/psci/Main.hs b/psci/Main.hs
index 52d7dae..f52be1a 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -17,45 +17,40 @@
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.
@@ -132,7 +127,7 @@ loadModule filename = either (Left . show) Right . P.runIndentParser filename P.
--
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 @@ completion = completeWord Nothing " \t\n\r" findCompletions
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 @@ makeIO = Make . ErrorT . fmap (either (Left . show) Right) . tryIOError
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 @@ createTemporaryModule exec PSCiState{psciImportedModuleNames = imports, psciLetB
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 @@ handleDeclaration value = do
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 @@ handleDeclaration value = do
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 :: Command -> PSCI ()
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 @@ handleCommand Reset = do
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 @@ loop singleLineMode files = do
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 }
diff --git a/purescript.cabal b/purescript.cabal
index 80f68be..b5094a7 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -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 @@ source-repository head
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 @@ library
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 @@ executable psci
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
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index 7ddf4c5..92b5963 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -19,7 +19,7 @@ module Language.PureScript (module P, compile, compile', RebuildPolicy(..), Mona
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 @@ class MonadMake m where
data RebuildPolicy
-- | Never rebuild this module
= RebuildNever
- -- | Always rebuild this module
+ -- | Always rebuild this module
| RebuildAlways deriving (Show, Eq, Ord)
-- |
@@ -163,7 +163,7 @@ make outputDir opts ms prefix = do
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
diff --git a/src/Language/PureScript/AST.hs b/src/Language/PureScript/AST.hs
new file mode 100644
index 0000000..7e4e692
--- /dev/null
+++ b/src/Language/PureScript/AST.hs
@@ -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
diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs
new file mode 100644
index 0000000..50c1a62
--- /dev/null
+++ b/src/Language/PureScript/AST/Binders.hs
@@ -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
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
new file mode 100644
index 0000000..8a9d163
--- /dev/null
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -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)
diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs
new file mode 100644
index 0000000..0aa46af
--- /dev/null
+++ b/src/Language/PureScript/AST/Operators.hs
@@ -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)
diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs
new file mode 100644
index 0000000..dc9ee44
--- /dev/null
+++ b/src/Language/PureScript/AST/SourcePos.hs
@@ -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)
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/AST/Traversals.hs
index e21567b..464d7f0 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/AST/Traversals.hs
@@ -1,490 +1,30 @@
-----------------------------------------------------------------------------
--
--- Module : Language.PureScript.Declarations
--- Copyright : (c) Phil Freeman 2013
+-- 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 :
--
--- | Data types for modules and declarations
+-- | AST traversal helpers
--
-----------------------------------------------------------------------------
-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}
-
-module Language.PureScript.Declarations where
+module Language.PureScript.AST.Traversals where
import Data.Monoid (Monoid(..), mconcat)
-import qualified Data.Data as D
-
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.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) ->
@@ -493,7 +33,7 @@ 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' (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))
@@ -531,8 +71,7 @@ everywhereOnValues f g h = (f', g', h')
handleCaseAlternative :: CaseAlternative -> CaseAlternative
handleCaseAlternative ca =
ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)
- , caseAlternativeGuard = fmap g' (caseAlternativeGuard ca)
- , caseAlternativeResult = g' (caseAlternativeResult ca)
+ , caseAlternativeResult = (map (g' *** g') +++ g') (caseAlternativeResult ca)
}
handleDoNotationElement :: DoNotationElement -> DoNotationElement
@@ -550,7 +89,7 @@ everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>
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' (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
@@ -583,9 +122,8 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< 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
+ 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
@@ -600,7 +138,7 @@ everywhereOnValuesM :: (Functor m, Applicative m, Monad m) =>
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' (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
@@ -608,7 +146,7 @@ everywhereOnValuesM f g h = (f' <=< f, g' <=< g, h' <=< h)
f' other = f other
g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g
- g' (BinaryNoParens op v1 v2) = (BinaryNoParens op <$> (g' v1) <*> (g' v2)) >>= 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
@@ -633,9 +171,8 @@ everywhereOnValuesM f g h = (f' <=< f, g' <=< g, h' <=< 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
+ 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
@@ -652,8 +189,8 @@ everythingOnValues :: (r -> r -> 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@(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)
@@ -673,7 +210,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
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@(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
@@ -686,9 +223,8 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
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)
+ 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
@@ -700,12 +236,12 @@ everythingWithContextOnValues ::
r ->
(r -> r -> r) ->
(s -> Declaration -> (s, r)) ->
- (s -> Expr -> (s, r)) ->
+ (s -> Expr -> (s, r)) ->
(s -> Binder -> (s, r)) ->
(s -> CaseAlternative -> (s, r)) ->
(s -> DoNotationElement -> (s, r)) ->
( Declaration -> r
- , Expr -> r
+ , Expr -> r
, Binder -> r
, CaseAlternative -> r
, DoNotationElement -> r)
@@ -714,32 +250,32 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
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 (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' 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 (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 (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 (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' s (PositionedValue _ v1) = g'' s v1
g' _ _ = r0
h'' s b = let (s', r) = h s b in r <> h' s' b
@@ -747,32 +283,32 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
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' 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
+ 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 (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
+ 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 -> 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
+ , Expr -> m Expr
, Binder -> m Binder
, CaseAlternative -> m CaseAlternative
, DoNotationElement -> m DoNotationElement)
@@ -781,7 +317,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
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 (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
@@ -795,7 +331,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
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 (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
@@ -820,7 +356,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
i'' s = uncurry i' <=< i s
- i' s (CaseAlternative bs grd val) = CaseAlternative <$> mapM (h'' s) bs <*> maybeM (g'' s) grd <*> g'' s val
+ 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
@@ -845,5 +381,3 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con
forValues (SuperClassDictionary _ tys) = mconcat (map f tys)
forValues (TypedValue _ _ ty) = f ty
forValues _ = mempty
-
-
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index 76b49c7..8efba66 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -26,7 +26,7 @@ import Control.Monad.Writer
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 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite
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"]
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index db8b6e9..2f8e966 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -33,7 +33,7 @@ import Control.Applicative
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 @@ imports other =
-- 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 :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName
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
diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs
index b51ed9a..8ef5e38 100644
--- a/src/Language/PureScript/Constants.hs
+++ b/src/Language/PureScript/Constants.hs
@@ -153,6 +153,9 @@ mkFn = "mkFn"
runFn :: String
runFn = "runFn"
+unit :: String
+unit = "unit"
+
-- Prim values
undefined :: String
diff --git a/src/Language/PureScript/DeadCodeElimination.hs b/src/Language/PureScript/DeadCodeElimination.hs
index 0d55e01..9f96f15 100644
--- a/src/Language/PureScript/DeadCodeElimination.hs
+++ b/src/Language/PureScript/DeadCodeElimination.hs
@@ -21,7 +21,7 @@ import Data.Graph
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 @@ eliminateDeadCode entryPoints ms = map go ms
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 -> [(Key, [Key])]
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 @@ dependencies moduleName =
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) =
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 11555ff..7b43e00 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -23,7 +23,7 @@ import Data.Monoid
import Control.Monad.Error
import Control.Applicative ((<$>))
-import Language.PureScript.Declarations
+import Language.PureScript.AST
import Language.PureScript.Pretty
import Language.PureScript.Types
diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs
index e191e15..76ab371 100644
--- a/src/Language/PureScript/ModuleDependencies.hs
+++ b/src/Language/PureScript/ModuleDependencies.hs
@@ -21,7 +21,7 @@ import Data.Graph
import Data.List (nub)
import Data.Maybe (mapMaybe)
-import Language.PureScript.Declarations
+import Language.PureScript.AST
import Language.PureScript.Names
import Language.PureScript.Types
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index 850920b..feb9e12 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -134,6 +134,12 @@ identifier :: P.Parsec String u String
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 ()
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 6adfea9..676e014 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -35,7 +35,7 @@ import Control.Arrow ((+++))
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 @@ sourcePos = toSourcePos <$> P.getPosition
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 @@ parseDataDeclaration = do
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 :: P.Parsec String ParseState Declaration
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 @@ parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "imp
<|> (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 @@ parseTypeClassDeclaration = do
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 @@ parseTypeInstanceDeclaration = do
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 @@ parseModule = do
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 :: P.Parsec String ParseState Expr
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 @@ parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.rese
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 @@ parseValueAtom = P.choice
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 @@ parseNullBinder = C.lexeme (P.char '_' *> P.notFollowedBy C.identLetter) *> retu
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 @@ parseBinderNoParens = P.choice (map P.try
-- Parse a guard
--
parseGuard :: P.Parsec String ParseState Guard
-parseGuard = C.indented *> C.pipe *> C.indented *> parseValue
+parseGuard = C.pipe *> C.indented *> parseValue
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
index 413ae90..3dab411 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -16,6 +16,7 @@
module Language.PureScript.Parser.Types (
parseType,
parsePolyType,
+ noWildcards,
parseTypeAtom
) where
@@ -43,6 +44,9 @@ parseFunction = parens $ P.try (lexeme (P.string "->")) >> return tyFunction
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 @@ parseTypeAtom = indented *> P.choice (map P.try
, parseArrayOf
, parseFunction
, parseObject
+ , parseTypeWildcard
, parseTypeVariable
, parseTypeConstructor
, parseForAll
@@ -108,8 +113,17 @@ parseType = do
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))
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index d4681b3..5c8ea9c 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -34,6 +34,7 @@ import Language.PureScript.Environment
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 ++ "]"
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index b560446..667a62d 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -26,7 +26,7 @@ import Control.PatternArrows
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 @@ literals = mkPattern' match
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 (PositionedDeclaration _ d) = prettyPrintDeclaration d
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) =
diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs
index 907b3db..8ea17e4 100644
--- a/src/Language/PureScript/Renamer.hs
+++ b/src/Language/PureScript/Renamer.hs
@@ -23,7 +23,7 @@ import Data.List (find)
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 @@ lookupIdent name = do
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 @@ renameInModules = map go
-- 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 @@ renameInValue v = return v
-- 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.
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index 5296f6e..46f25de 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -19,7 +19,7 @@ import Control.Monad
import Control.Category ((>>>))
import Control.Monad.Trans.Class
-import Language.PureScript.Declarations
+import Language.PureScript.AST
import Language.PureScript.Errors
import Language.PureScript.Supply
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index 5baf578..c7df1b1 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -29,7 +29,7 @@ import Control.Applicative ((<$>), (<*>), pure)
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 :: [Declaration] -> [Declaration]
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 @@ usedIdents moduleName =
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 @@ usedImmediateIdents moduleName =
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 @@ usedProperNames moduleName =
usedNames _ = []
getIdent :: Declaration -> Ident
-getIdent (ValueDeclaration ident _ _ _ _) = ident
+getIdent (ValueDeclaration ident _ _ _) = ident
getIdent (PositionedDeclaration _ d) = getIdent d
getIdent _ = error "Expected ValueDeclaration"
@@ -147,7 +147,7 @@ getProperName _ = error "Expected DataDeclaration"
-- |
-- 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
@@ -176,7 +176,7 @@ toBindingGroup moduleName (CyclicSCC ds') =
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 (PositionedDeclaration _ d) = isTypeSynonym d
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"
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index 56ab9fb..0c47031 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -19,7 +19,7 @@ module Language.PureScript.Sugar.CaseDeclarations (
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 ((<=<), forM, join, unless, replicateM)
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 @@ desugarAbs = flip parU f
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 @@ desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGro
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 @@ desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGro
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 :: Binder -> Bool
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)
diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
index e9595f3..596a7e1 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -19,7 +19,7 @@ module Language.PureScript.Sugar.DoNotation (
) 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 @@ desugarDo d =
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
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index 80673be..1891586 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -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 @@ module Language.PureScript.Sugar.Names (
desugarImports
) where
+import Data.List (nub)
import Data.Maybe (fromMaybe, isJust, mapMaybe)
import Data.Monoid ((<>))
@@ -24,7 +25,7 @@ import Control.Monad.Error
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 @@ desugarImports modules = do
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 @@ elaborateExports exps (Module mn decls _) = Module mn decls (Just $
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 @@ renameInModule imports exports (Module mn decls exps) =
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 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri
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
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index e5cc304..8b63595 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -25,7 +25,7 @@ module Language.PureScript.Sugar.Operators (
) where
import Language.PureScript.Names
-import Language.PureScript.Declarations
+import Language.PureScript.AST
import Language.PureScript.Errors
import Control.Applicative
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index b131cb9..e0ea15e 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -18,7 +18,7 @@ module Language.PureScript.Sugar.TypeClasses (
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 @@ typeClassDictionaryDeclaration name args implies members =
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 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
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 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
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"
diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs
index c4e3825..31b6a07 100644
--- a/src/Language/PureScript/Sugar/TypeDeclarations.hs
+++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs
@@ -25,10 +25,11 @@ import Control.Applicative
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 @@ desugarTypeDeclarations (PositionedDeclaration pos d : ds) = do
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
diff --git a/src/Language/PureScript/Traversals.hs b/src/Language/PureScript/Traversals.hs
index c456d53..3132327 100644
--- a/src/Language/PureScript/Traversals.hs
+++ b/src/Language/PureScript/Traversals.hs
@@ -25,10 +25,17 @@ sndM f (a, b) = (,) a <$> f b
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)
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index fc1ebed..55cfe8b 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -37,7 +37,7 @@ import Control.Monad.Error
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 @@ typeCheckAll mainModuleName moduleName exps = go
(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 @@ typeCheckAll mainModuleName moduleName exps = go
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 @@ typeCheckAll mainModuleName moduleName exps = go
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 @@ typeCheckAll mainModuleName moduleName exps = go
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)]
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
new file mode 100644
index 0000000..89e94ac
--- /dev/null
+++ b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -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
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index 1a7f168..c83e37c 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -22,23 +22,23 @@ module Language.PureScript.TypeChecker.Kinds (
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 @@ instance Partial Kind where
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 @@ kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do
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 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do
-- |
-- 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 :: Type -> UnifyT Kind Check Kind
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 @@ infer' (KindedType ty k) = do
k =?= k'
return k'
infer' _ = error "Invalid argument to infer"
-
-
-
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index e8b1935..14c04d8 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -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
diff --git a/src/Language/PureScript/TypeChecker/Rows.hs b/src/Language/PureScript/TypeChecker/Rows.hs
new file mode 100644
index 0000000..1c3115a
--- /dev/null
+++ b/src/Language/PureScript/TypeChecker/Rows.hs
@@ -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
diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs
new file mode 100644
index 0000000..f99413c
--- /dev/null
+++ b/src/Language/PureScript/TypeChecker/Skolems.hs
@@ -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))
diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs
new file mode 100644
index 0000000..5d8ab24
--- /dev/null
+++ b/src/Language/PureScript/TypeChecker/Subsumption.hs
@@ -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
diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs
index 1a3be4e..7ad00e2 100644
--- a/src/Language/PureScript/TypeChecker/Synonyms.hs
+++ b/src/Language/PureScript/TypeChecker/Synonyms.hs
@@ -13,17 +13,28 @@
--
-----------------------------------------------------------------------------
+{-# 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 @@ saturateTypeSynonym name n = everywhereOnTypesTopDownM replace
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
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index f8988e0..2a71eab 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -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,137 +33,37 @@ module Language.PureScript.TypeChecker.Types (
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 @@ typeDictionaryForBindingGroup moduleName vals = do
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 @@ typeForBindingGroupElement (ident, val) dict untypedDict = do
-- |
-- 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 @@ replaceTypeClassDictionaries mn =
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 (ConstrainedType constraints ty) = do
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' (App f arg) = do
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 @@ infer' (SuperClassDictionary className tys) = do
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 @@ infer' _ = error "Invalid argument to infer"
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 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
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 @@ inferBinder val (PositionedBinder pos binder) =
--
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 @@ check' v@(Var var) ty = do
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 @@ check' (SuperClassDictionary className tys) _ = do
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 @@ check' (Constructor c) ty = do
_ <- 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 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
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 u@(TUnknown _) arg ret = do
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 @@ meet e1 e2 t1 t2 = do
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
diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs
new file mode 100644
index 0000000..23e9f93
--- /dev/null
+++ b/src/Language/PureScript/TypeChecker/Unify.hs
@@ -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'
diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs
index 559bb89..d105eb6 100644
--- a/src/Language/PureScript/TypeClassDictionaries.hs
+++ b/src/Language/PureScript/TypeClassDictionaries.hs
@@ -64,3 +64,10 @@ data TypeClassDictionaryType
-- 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
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index 0fad74d..9a071e9 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -47,6 +47,10 @@ data Type
--
| TypeVar String
-- |
+ -- A type wildcard, as would appear in a partial type synonym
+ --
+ | TypeWildcard
+ -- |
-- A type constructor
--
| TypeConstructor (Qualified ProperName)
@@ -215,6 +219,16 @@ moveQuantifiersToFront = go [] []
[] -> 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
--