diff --git a/examples/failing/TypeWildcards1.purs b/examples/failing/TypeWildcards1.purs new file mode 100644 --- /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 --- /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 --- /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 --- a/examples/passing/Guards.purs +++ b/examples/passing/Guards.purs @@ -11,4 +11,13 @@ z | y > 0 -> z / 2 z -> z * 3 + 1 - main = Debug.Trace.trace "Done" + min :: forall a. (Ord a) => a -> a -> a + min n m | n < m = n + | otherwise = m + + max :: forall a. (Ord a) => a -> a -> a + max n m = case unit of + _ | m < n -> n + | otherwise -> m + + main = Debug.Trace.trace $ min "Done" "ZZZZ" diff --git a/examples/passing/ImplicitEmptyImport.purs b/examples/passing/ImplicitEmptyImport.purs new file mode 100644 --- /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 --- /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 --- /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 --- a/prelude/prelude.purs +++ b/prelude/prelude.purs @@ -1,5 +1,6 @@ module Prelude - ( flip + ( otherwise + , flip , const , asTypeOf , Semigroupoid, (<<<), (>>>) @@ -7,7 +8,7 @@ , ($), (#) , (:), cons , Show, show - , Functor, (<$>), void + , Functor, (<$>), (<#>), void , Apply, (<*>) , Applicative, pure, liftA1 , Bind, (>>=) @@ -23,6 +24,9 @@ , Unit(..), unit ) where + otherwise :: Boolean + otherwise = true + flip :: forall a b c. (a -> b -> c) -> b -> a -> c flip f b a = f a b @@ -111,9 +115,13 @@ show = showArrayImpl show infixl 4 <$> + infixl 1 <#> class Functor f where (<$>) :: forall a b. (a -> b) -> f a -> f b + + (<#>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b + (<#>) fa f = f <$> fa void :: forall f a. (Functor f) => f a -> f Unit void fa = const unit <$> fa diff --git a/psci/Main.hs b/psci/Main.hs --- a/psci/Main.hs +++ b/psci/Main.hs @@ -17,46 +17,41 @@ module Main where -import Commands +import Data.Foldable (traverse_) +import Data.List (intercalate, isPrefixOf, nub, sortBy, sort) +import Data.Maybe (mapMaybe) +import Data.Traversable (traverse) +import Data.Version (showVersion) +import qualified Data.Map as M import Control.Applicative import Control.Monad +import Control.Monad.Error (ErrorT(..), MonadError) +import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.Trans.State.Strict import qualified Control.Monad.Trans.State.Lazy as L -import Control.Monad.Error (ErrorT(..), MonadError) -import Control.Monad.Error.Class (MonadError(..)) -import Data.List (intercalate, isPrefixOf, nub, sortBy, sort) -import Data.Maybe (mapMaybe) -import Data.Foldable (traverse_) -import Data.Version (showVersion) -import Data.Traversable (traverse) - -import Parser - -import System.IO.Error (tryIOError) import System.Console.Haskeline -import System.Directory - (createDirectoryIfMissing, getModificationTime, doesFileExist, - findExecutable, getHomeDirectory, getCurrentDirectory) -import System.Process (readProcessWithExitCode) +import System.Directory (createDirectoryIfMissing, getModificationTime, doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory) import System.Exit -import System.FilePath - (pathSeparator, takeDirectory, (), isPathSeparator) +import System.FilePath (pathSeparator, takeDirectory, (), isPathSeparator) +import System.IO.Error (tryIOError) +import System.Process (readProcessWithExitCode) import qualified System.Console.CmdTheLine as Cmd +import qualified System.IO.UTF8 as U (writeFile, putStrLn, print, readFile) import Text.Parsec (ParseError) -import qualified Data.Map as M import qualified Language.PureScript as P -import qualified Paths_purescript as Paths -import qualified System.IO.UTF8 as U - (writeFile, putStrLn, print, readFile) +import qualified Language.PureScript.AST as D import qualified Language.PureScript.Names as N -import qualified Language.PureScript.Declarations as D +import qualified Paths_purescript as Paths +import Commands +import Parser + -- | -- The PSCI state. -- Holds a list of imported modules, loaded files, and partial let bindings. @@ -132,7 +127,7 @@ -- loadAllModules :: [FilePath] -> IO (Either ParseError [(Either P.RebuildPolicy FilePath, P.Module)]) loadAllModules files = do - filesAndContent <- forM files $ \filename -> do + filesAndContent <- forM files $ \filename -> do content <- U.readFile filename return (Right filename, content) return $ P.parseModulesFromFiles (either (const "") id) $ (Left P.RebuildNever, P.prelude) : filesAndContent @@ -191,8 +186,8 @@ let matches = filter (isPrefixOf str) (names ms) return $ sortBy sorter $ map simpleCompletion matches ++ files getDeclName :: Maybe [P.DeclarationRef] -> P.Declaration -> Maybe P.Ident - getDeclName Nothing (P.ValueDeclaration ident _ _ _ _) = Just ident - getDeclName (Just exts) (P.ValueDeclaration ident _ _ _ _) | isExported = Just ident + getDeclName Nothing (P.ValueDeclaration ident _ _ _) = Just ident + getDeclName (Just exts) (P.ValueDeclaration ident _ _ _) | isExported = Just ident where isExported = any exports exts exports (P.ValueRef ident') = ident == ident' @@ -236,9 +231,9 @@ instance P.MonadMake Make where getTimestamp path = makeIO $ do exists <- doesFileExist path - case exists of - True -> Just <$> getModificationTime path - False -> return Nothing + if exists + then Just <$> getModificationTime path + else return Nothing readTextFile path = makeIO $ U.readFile path writeTextFile path text = makeIO $ do mkdirp path @@ -261,8 +256,8 @@ trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print")) itValue = foldl (\x f -> f x) value lets mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it"))) - itDecl = P.ValueDeclaration (P.Ident "it") P.Value [] Nothing itValue - mainDecl = P.ValueDeclaration (P.Ident "main") P.Value [] Nothing mainValue + itDecl = P.ValueDeclaration (P.Ident "it") P.Value [] $ Right itValue + mainDecl = P.ValueDeclaration (P.Ident "main") P.Value [] $ Right mainValue decls = if exec then [itDecl, mainDecl] else [itDecl] in P.Module moduleName ((importDecl `map` imports) ++ decls) Nothing @@ -307,7 +302,7 @@ case e of Left err -> PSCI $ outputStrLn err Right _ -> do - psciIO $ writeFile indexFile $ "require('$PSCI').main();" + psciIO $ writeFile indexFile "require('$PSCI').main();" process <- psciIO findNodeProcess result <- psciIO $ traverse (\node -> readProcessWithExitCode node [indexFile] "") process case result of @@ -316,6 +311,20 @@ Nothing -> PSCI $ outputStrLn "Couldn't find node.js" -- | +-- Takes a let declaration and updates the environment, then run a make. If the declaration fails, +-- restore the pre-let environment. +-- +handleLet :: (P.Expr -> P.Expr) -> PSCI () +handleLet l = do + st <- PSCI $ lift get + let st' = updateLets l st + let m = createTemporaryModule False st' (P.ObjectLiteral []) + e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st' ++ [(Left P.RebuildAlways, m)]) [] + case e of + Left err -> PSCI $ outputStrLn err + Right _ -> PSCI $ lift (put st') + +-- | -- Show actual loaded modules in psci. -- handleShowLoadedModules :: PSCI () @@ -444,7 +453,7 @@ handleCommand (Expression val) = handleDeclaration val handleCommand Help = PSCI $ outputStrLn helpMessage handleCommand (Import moduleName) = handleImport moduleName -handleCommand (Let l) = PSCI $ lift $ modify (updateLets l) +handleCommand (Let l) = handleLet l handleCommand (LoadFile filePath) = do absPath <- psciIO $ expandTilde filePath exists <- psciIO $ doesFileExist absPath @@ -460,7 +469,7 @@ files <- psciImportedFilenames <$> PSCI (lift get) modulesOrFirstError <- psciIO $ loadAllModules files case modulesOrFirstError of - Left err -> psciIO $ putStrLn (show err) >> exitFailure + Left err -> psciIO $ print err >> exitFailure Right modules -> PSCI . lift $ put (PSCiState files defaultImports modules []) handleCommand (TypeOf val) = handleTypeOf val handleCommand (KindOf typ) = handleKindOf typ @@ -501,7 +510,7 @@ config <- loadUserConfig modulesOrFirstError <- loadAllModules files case modulesOrFirstError of - Left err -> putStrLn (show err) >> exitFailure + Left err -> print err >> exitFailure Right modules -> do historyFilename <- getHistoryFilename let settings = defaultSettings { historyFile = Just historyFilename } diff --git a/purescript.cabal b/purescript.cabal --- 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 @@ location: https://github.com/purescript/purescript.git library - build-depends: base >=4 && <5, - cmdtheline == 0.2.*, - containers -any, + build-depends: base >=4 && <5, + cmdtheline == 0.2.*, + containers -any, unordered-containers -any, - directory >= 1.2, - filepath -any, - mtl >= 2.1.0 && < 2.3.0, + directory >= 1.2, + filepath -any, + mtl >= 2.1.0 && < 2.3.0, parsec -any, - transformers >= 0.3 && < 0.5, + transformers >= 0.3 && < 0.5, utf8-string -any, pattern-arrows >= 0.0.2 && < 0.1, - monad-unify >= 0.2.2 && < 0.3, + monad-unify >= 0.2.2 && < 0.3, file-embed >= 0.0.7 && < 0.0.8, time -any exposed-modules: Language.PureScript - Language.PureScript.Constants - Language.PureScript.Options - Language.PureScript.Declarations - Language.PureScript.Environment - Language.PureScript.Errors - Language.PureScript.Kinds - Language.PureScript.Names - Language.PureScript.Supply - Language.PureScript.Types - Language.PureScript.Traversals - Language.PureScript.TypeClassDictionaries - Language.PureScript.DeadCodeElimination - Language.PureScript.Sugar - Language.PureScript.ModuleDependencies - Language.PureScript.Sugar.CaseDeclarations - Language.PureScript.Sugar.DoNotation - Language.PureScript.Sugar.TypeDeclarations - Language.PureScript.Sugar.BindingGroups - Language.PureScript.Sugar.Operators - Language.PureScript.Sugar.TypeClasses - Language.PureScript.Sugar.Names + Language.PureScript.AST + Language.PureScript.AST.Binders + Language.PureScript.AST.Declarations + Language.PureScript.AST.Operators + Language.PureScript.AST.SourcePos + Language.PureScript.AST.Traversals Language.PureScript.CodeGen Language.PureScript.CodeGen.Common Language.PureScript.CodeGen.Externs Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.JS.AST + Language.PureScript.Constants + Language.PureScript.DeadCodeElimination + Language.PureScript.Environment + Language.PureScript.Errors + Language.PureScript.Kinds + Language.PureScript.ModuleDependencies + Language.PureScript.Names Language.PureScript.Optimizer + Language.PureScript.Optimizer.Blocks Language.PureScript.Optimizer.Common + Language.PureScript.Optimizer.Inliner Language.PureScript.Optimizer.MagicDo Language.PureScript.Optimizer.TCO - Language.PureScript.Optimizer.Inliner Language.PureScript.Optimizer.Unused - Language.PureScript.Optimizer.Blocks + Language.PureScript.Options Language.PureScript.Parser Language.PureScript.Parser.Common Language.PureScript.Parser.Declarations @@ -85,11 +78,28 @@ Language.PureScript.Pretty.Types Language.PureScript.Pretty.Values Language.PureScript.Renamer + Language.PureScript.Sugar + Language.PureScript.Sugar.BindingGroups + Language.PureScript.Sugar.CaseDeclarations + Language.PureScript.Sugar.DoNotation + Language.PureScript.Sugar.Names + Language.PureScript.Sugar.Operators + Language.PureScript.Sugar.TypeClasses + Language.PureScript.Sugar.TypeDeclarations + Language.PureScript.Supply + Language.PureScript.Traversals Language.PureScript.TypeChecker + Language.PureScript.TypeChecker.Entailment Language.PureScript.TypeChecker.Kinds Language.PureScript.TypeChecker.Monad + Language.PureScript.TypeChecker.Rows + Language.PureScript.TypeChecker.Skolems + Language.PureScript.TypeChecker.Subsumption Language.PureScript.TypeChecker.Synonyms Language.PureScript.TypeChecker.Types + Language.PureScript.TypeChecker.Unify + Language.PureScript.TypeClassDictionaries + Language.PureScript.Types exposed: True buildable: True hs-source-dirs: src @@ -128,12 +138,12 @@ Parser ghc-options: -Wall -O2 -executable psc-docs +executable psc-docs build-depends: base >=4 && <5, cmdtheline -any, purescript -any, utf8-string -any, process -any, mtl -any main-is: Main.hs buildable: True - hs-source-dirs: psc-docs + hs-source-dirs: psc-docs other-modules: ghc-options: -Wall -O2 diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs --- a/src/Language/PureScript.hs +++ b/src/Language/PureScript.hs @@ -19,7 +19,7 @@ import Language.PureScript.Types as P import Language.PureScript.Kinds as P -import Language.PureScript.Declarations as P +import Language.PureScript.AST as P import Language.PureScript.Names as P import Language.PureScript.Parser as P import Language.PureScript.CodeGen as P @@ -139,7 +139,7 @@ data RebuildPolicy -- | Never rebuild this module = RebuildNever - -- | Always rebuild this module + -- | Always rebuild this module | RebuildAlways deriving (Show, Eq, Ord) -- | @@ -163,7 +163,7 @@ jsTimestamp <- getTimestamp jsFile externsTimestamp <- getTimestamp externsFile - inputTimestamp <- traverse getTimestamp inputFile + inputTimestamp <- traverse getTimestamp inputFile return $ case (inputTimestamp, jsTimestamp, externsTimestamp) of (Right (Just t1), Just t2, Just t3) | t1 < min t2 t3 -> s diff --git a/src/Language/PureScript/AST.hs b/src/Language/PureScript/AST.hs new file mode 100644 --- /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 +-- 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 --- /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 +-- 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 --- /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 +-- 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 --- /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 +-- 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 --- /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 +-- 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/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/AST/Traversals.hs @@ -0,0 +1,383 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.AST.Traversals +-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- Stability : experimental +-- Portability : +-- +-- | AST traversal helpers +-- +----------------------------------------------------------------------------- + +module Language.PureScript.AST.Traversals where + +import Data.Monoid (Monoid(..), mconcat) + +import Control.Applicative +import Control.Monad +import Control.Arrow ((***), (+++)) + +import Language.PureScript.AST.Binders +import Language.PureScript.AST.Declarations +import Language.PureScript.Types +import Language.PureScript.Traversals + +everywhereOnValues :: (Declaration -> Declaration) -> + (Expr -> Expr) -> + (Binder -> Binder) -> + (Declaration -> Declaration, Expr -> Expr, Binder -> Binder) +everywhereOnValues f g h = (f', g', h') + where + f' :: Declaration -> Declaration + f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (map f' ds)) + f' (ValueDeclaration name nameKind bs val) = f (ValueDeclaration name nameKind (map h' bs) ((map (g' *** g') +++ g') val)) + f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds)) + f' (TypeClassDeclaration name args implies ds) = f (TypeClassDeclaration name args implies (map f' ds)) + f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (map f' ds)) + f' (PositionedDeclaration pos d) = f (PositionedDeclaration pos (f' d)) + f' other = f other + + g' :: Expr -> Expr + g' (UnaryMinus v) = g (UnaryMinus (g' v)) + g' (BinaryNoParens op v1 v2) = g (BinaryNoParens op (g' v1) (g' v2)) + g' (Parens v) = g (Parens (g' v)) + g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs)) + g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs)) + g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v)) + g' (Accessor prop v) = g (Accessor prop (g' v)) + g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs)) + g' (Abs name v) = g (Abs name (g' v)) + g' (App v1 v2) = g (App (g' v1) (g' v2)) + g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3)) + g' (Case vs alts) = g (Case (map g' vs) (map handleCaseAlternative alts)) + g' (TypedValue check v ty) = g (TypedValue check (g' v) ty) + g' (Let ds v) = g (Let (map f' ds) (g' v)) + g' (Do es) = g (Do (map handleDoNotationElement es)) + g' (PositionedValue pos v) = g (PositionedValue pos (g' v)) + g' other = g other + + h' :: Binder -> Binder + h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs)) + h' (ObjectBinder bs) = h (ObjectBinder (map (fmap h') bs)) + h' (ArrayBinder bs) = h (ArrayBinder (map h' bs)) + h' (ConsBinder b1 b2) = h (ConsBinder (h' b1) (h' b2)) + h' (NamedBinder name b) = h (NamedBinder name (h' b)) + h' (PositionedBinder pos b) = h (PositionedBinder pos (h' b)) + h' other = h other + + handleCaseAlternative :: CaseAlternative -> CaseAlternative + handleCaseAlternative ca = + ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca) + , caseAlternativeResult = (map (g' *** g') +++ g') (caseAlternativeResult ca) + } + + handleDoNotationElement :: DoNotationElement -> DoNotationElement + handleDoNotationElement (DoNotationValue v) = DoNotationValue (g' v) + handleDoNotationElement (DoNotationBind b v) = DoNotationBind (h' b) (g' v) + handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds) + handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos (handleDoNotationElement e) + + +everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) => + (Declaration -> m Declaration) -> + (Expr -> m Expr) -> + (Binder -> m Binder) -> + (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder) +everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) + where + f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f' <=< f) ds + f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h' <=< h) bs <*> eitherM (mapM (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val + f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds + f' (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f' <=< f) ds + f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f' <=< f) ds + f' (PositionedDeclaration pos d) = PositionedDeclaration pos <$> (f d >>= f') + f' other = f other + + g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g') + g' (BinaryNoParens op v1 v2) = BinaryNoParens op <$> (g v1 >>= g') <*> (g v2 >>= g') + g' (Parens v) = Parens <$> (g v >>= g') + g' (ArrayLiteral vs) = ArrayLiteral <$> mapM (g' <=< g) vs + g' (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g' <=< g)) vs + g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g') + g' (Accessor prop v) = Accessor prop <$> (g v >>= g') + g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> mapM (sndM (g' <=< g)) vs + g' (Abs name v) = Abs name <$> (g v >>= g') + g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g') + g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g') + g' (Case vs alts) = Case <$> mapM (g' <=< g) vs <*> mapM handleCaseAlternative alts + g' (TypedValue check v ty) = TypedValue check <$> (g v >>= g') <*> pure ty + g' (Let ds v) = Let <$> mapM (f' <=< f) ds <*> (g v >>= g') + g' (Do es) = Do <$> mapM handleDoNotationElement es + g' (PositionedValue pos v) = PositionedValue pos <$> (g v >>= g') + g' other = g other + + h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h' <=< h) bs + h' (ObjectBinder bs) = ObjectBinder <$> mapM (sndM (h' <=< h)) bs + h' (ArrayBinder bs) = ArrayBinder <$> mapM (h' <=< h) bs + h' (ConsBinder b1 b2) = ConsBinder <$> (h b1 >>= h') <*> (h b2 >>= h') + h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h') + h' (PositionedBinder pos b) = PositionedBinder pos <$> (h b >>= h') + h' other = h other + + handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM (h' <=< h) bs + <*> eitherM (mapM (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val + + handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v + handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v + handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM (f' <=< f) ds + handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos <$> handleDoNotationElement e + +everywhereOnValuesM :: (Functor m, Applicative m, Monad m) => + (Declaration -> m Declaration) -> + (Expr -> m Expr) -> + (Binder -> m Binder) -> + (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder) +everywhereOnValuesM f g h = (f' <=< f, g' <=< g, h' <=< h) + where + f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> mapM f' ds) >>= f + f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> mapM h' bs <*> eitherM (mapM (pairM g' g')) g' val) >>= f + f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f + f' (TypeClassDeclaration name args implies ds) = (TypeClassDeclaration name args implies <$> mapM f' ds) >>= f + f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> mapM f' ds) >>= f + f' (PositionedDeclaration pos d) = (PositionedDeclaration pos <$> f' d) >>= f + f' other = f other + + g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g + g' (BinaryNoParens op v1 v2) = (BinaryNoParens op <$> g' v1 <*> g' v2) >>= g + g' (Parens v) = (Parens <$> g' v) >>= g + g' (ArrayLiteral vs) = (ArrayLiteral <$> mapM g' vs) >>= g + g' (ObjectLiteral vs) = (ObjectLiteral <$> mapM (sndM g') vs) >>= g + g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g + g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g + g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> mapM (sndM g') vs) >>= g + g' (Abs name v) = (Abs name <$> g' v) >>= g + g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g + g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g + g' (Case vs alts) = (Case <$> mapM g' vs <*> mapM handleCaseAlternative alts) >>= g + g' (TypedValue check v ty) = (TypedValue check <$> g' v <*> pure ty) >>= g + g' (Let ds v) = (Let <$> mapM f' ds <*> g' v) >>= g + g' (Do es) = (Do <$> mapM handleDoNotationElement es) >>= g + g' (PositionedValue pos v) = (PositionedValue pos <$> g' v) >>= g + g' other = g other + + h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> mapM h' bs) >>= h + h' (ObjectBinder bs) = (ObjectBinder <$> mapM (sndM h') bs) >>= h + h' (ArrayBinder bs) = (ArrayBinder <$> mapM h' bs) >>= h + h' (ConsBinder b1 b2) = (ConsBinder <$> h' b1 <*> h' b2) >>= h + h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h + h' (PositionedBinder pos b) = (PositionedBinder pos <$> h' b) >>= h + h' other = h other + + handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM h' bs + <*> eitherM (mapM (pairM g' g')) g' val + + handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v + handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v + handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM f' ds + handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos <$> handleDoNotationElement e + +everythingOnValues :: (r -> r -> r) -> + (Declaration -> r) -> + (Expr -> r) -> + (Binder -> r) -> + (CaseAlternative -> r) -> + (DoNotationElement -> r) -> + (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r) +everythingOnValues (<>) f g h i j = (f', g', h', i', j') + where + f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds) + f' d@(ValueDeclaration _ _ bs (Right val)) = foldl (<>) (f d) (map h' bs) <> g' val + f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs) + f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds) + f' d@(TypeClassDeclaration _ _ _ ds) = foldl (<>) (f d) (map f' ds) + f' d@(TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds) + f' d@(PositionedDeclaration _ d1) = f d <> f' d1 + f' d = f d + + g' v@(UnaryMinus v1) = g v <> g' v1 + g' v@(BinaryNoParens _ v1 v2) = g v <> g' v1 <> g' v2 + g' v@(Parens v1) = g v <> g' v1 + g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs) + g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs) + g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1 + g' v@(Accessor _ v1) = g v <> g' v1 + g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs) + g' v@(Abs _ v1) = g v <> g' v1 + g' v@(App v1 v2) = g v <> g' v1 <> g' v2 + g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3 + g' v@(Case vs alts) = foldl (<>) (foldl (<>) (g v) (map g' vs)) (map i' alts) + g' v@(TypedValue _ v1 _) = g v <> g' v1 + g' v@(Let ds v1) = foldl (<>) (g v) (map f' ds) <> g' v1 + g' v@(Do es) = foldl (<>) (g v) (map j' es) + g' v@(PositionedValue _ v1) = g v <> g' v1 + g' v = g v + + h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs) + h' b@(ObjectBinder bs) = foldl (<>) (h b) (map (h' . snd) bs) + h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs) + h' b@(ConsBinder b1 b2) = h b <> h' b1 <> h' b2 + h' b@(NamedBinder _ b1) = h b <> h' b1 + h' b@(PositionedBinder _ b1) = h b <> h' b1 + h' b = h b + + i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val + i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs) + + j' e@(DoNotationValue v) = j e <> g' v + j' e@(DoNotationBind b v) = j e <> h' b <> g' v + j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds) + j' e@(PositionedDoNotationElement _ e1) = j e <> j' e1 + +everythingWithContextOnValues :: + s -> + r -> + (r -> r -> r) -> + (s -> Declaration -> (s, r)) -> + (s -> Expr -> (s, r)) -> + (s -> Binder -> (s, r)) -> + (s -> CaseAlternative -> (s, r)) -> + (s -> DoNotationElement -> (s, r)) -> + ( Declaration -> r + , Expr -> r + , Binder -> r + , CaseAlternative -> r + , DoNotationElement -> r) +everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0) + where + f'' s d = let (s', r) = f s d in r <> f' s' d + + f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds) + f' s (ValueDeclaration _ _ bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val + f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs) + f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> g'' s val) ds) + f' s (TypeClassDeclaration _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds) + f' s (TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds) + f' s (PositionedDeclaration _ d1) = f'' s d1 + f' _ _ = r0 + + g'' s v = let (s', r) = g s v in r <> g' s' v + + g' s (UnaryMinus v1) = g'' s v1 + g' s (BinaryNoParens _ v1 v2) = g'' s v1 <> g'' s v2 + g' s (Parens v1) = g'' s v1 + g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs) + g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs) + g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1 + g' s (Accessor _ v1) = g'' s v1 + g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs) + g' s (Abs _ v1) = g'' s v1 + g' s (App v1 v2) = g'' s v1 <> g'' s v2 + g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3 + g' s (Case vs alts) = foldl (<>) (foldl (<>) r0 (map (g'' s) vs)) (map (i'' s) alts) + g' s (TypedValue _ v1 _) = g'' s v1 + g' s (Let ds v1) = foldl (<>) r0 (map (f'' s) ds) <> g'' s v1 + g' s (Do es) = foldl (<>) r0 (map (j'' s) es) + g' s (PositionedValue _ v1) = g'' s v1 + g' _ _ = r0 + + h'' s b = let (s', r) = h s b in r <> h' s' b + + h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs) + h' s (ObjectBinder bs) = foldl (<>) r0 (map (h'' s . snd) bs) + h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs) + h' s (ConsBinder b1 b2) = h'' s b1 <> h'' s b2 + h' s (NamedBinder _ b1) = h'' s b1 + h' s (PositionedBinder _ b1) = h'' s b1 + h' _ _ = r0 + + i'' s ca = let (s', r) = i s ca in r <> i' s' ca + + i' s (CaseAlternative bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val + i' s (CaseAlternative bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs) + + j'' s e = let (s', r) = j s e in r <> j' s' e + + j' s (DoNotationValue v) = g'' s v + j' s (DoNotationBind b v) = h'' s b <> g'' s v + j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds) + j' s (PositionedDoNotationElement _ e1) = j'' s e1 + +everywhereWithContextOnValuesM :: (Functor m, Applicative m, Monad m) => + s -> + (s -> Declaration -> m (s, Declaration)) -> + (s -> Expr -> m (s, Expr)) -> + (s -> Binder -> m (s, Binder)) -> + (s -> CaseAlternative -> m (s, CaseAlternative)) -> + (s -> DoNotationElement -> m (s, DoNotationElement)) -> + ( Declaration -> m Declaration + , Expr -> m Expr + , Binder -> m Binder + , CaseAlternative -> m CaseAlternative + , DoNotationElement -> m DoNotationElement) +everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0) + where + f'' s = uncurry f' <=< f s + + f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f'' s) ds + f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h'' s) bs <*> eitherM (mapM (pairM (g'' s) (g'' s))) (g'' s) val + f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (thirdM (g'' s)) ds + f' s (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f'' s) ds + f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f'' s) ds + f' s (PositionedDeclaration pos d1) = PositionedDeclaration pos <$> f'' s d1 + f' _ other = return other + + g'' s = uncurry g' <=< g s + + g' s (UnaryMinus v) = UnaryMinus <$> g'' s v + g' s (BinaryNoParens op v1 v2) = BinaryNoParens op <$> g'' s v1 <*> g'' s v2 + g' s (Parens v) = Parens <$> g'' s v + g' s (ArrayLiteral vs) = ArrayLiteral <$> mapM (g'' s) vs + g' s (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g'' s)) vs + g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v + g' s (Accessor prop v) = Accessor prop <$> g'' s v + g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> mapM (sndM (g'' s)) vs + g' s (Abs name v) = Abs name <$> g'' s v + g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2 + g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3 + g' s (Case vs alts) = Case <$> mapM (g'' s) vs <*> mapM (i'' s) alts + g' s (TypedValue check v ty) = TypedValue check <$> g'' s v <*> pure ty + g' s (Let ds v) = Let <$> mapM (f'' s) ds <*> g'' s v + g' s (Do es) = Do <$> mapM (j'' s) es + g' s (PositionedValue pos v) = PositionedValue pos <$> g'' s v + g' _ other = return other + + h'' s = uncurry h' <=< h s + + h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h'' s) bs + h' s (ObjectBinder bs) = ObjectBinder <$> mapM (sndM (h'' s)) bs + h' s (ArrayBinder bs) = ArrayBinder <$> mapM (h'' s) bs + h' s (ConsBinder b1 b2) = ConsBinder <$> h'' s b1 <*> h'' s b2 + h' s (NamedBinder name b) = NamedBinder name <$> h'' s b + h' s (PositionedBinder pos b) = PositionedBinder pos <$> h'' s b + h' _ other = return other + + i'' s = uncurry i' <=< i s + + i' s (CaseAlternative bs val) = CaseAlternative <$> mapM (h'' s) bs <*> eitherM (mapM (pairM (g'' s) (g'' s))) (g'' s) val + + j'' s = uncurry j' <=< j s + + j' s (DoNotationValue v) = DoNotationValue <$> g'' s v + j' s (DoNotationBind b v) = DoNotationBind <$> h'' s b <*> g'' s v + j' s (DoNotationLet ds) = DoNotationLet <$> mapM (f'' s) ds + j' s (PositionedDoNotationElement pos e1) = PositionedDoNotationElement pos <$> j'' s e1 + +accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r) +accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty) + where + forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors) + forDecls (ExternDeclaration _ _ _ ty) = f ty + forDecls (ExternInstanceDeclaration _ cs _ tys) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys) + forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . snd) implies) + forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys) + forDecls (TypeSynonymDeclaration _ _ ty) = f ty + forDecls (TypeDeclaration _ ty) = f ty + forDecls _ = mempty + + forValues (TypeClassDictionary _ (_, cs) _) = mconcat (map f cs) + forValues (SuperClassDictionary _ tys) = mconcat (map f tys) + forValues (TypedValue _ _ ty) = f ty + forValues _ = mempty diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs --- a/src/Language/PureScript/CodeGen/Externs.hs +++ b/src/Language/PureScript/CodeGen/Externs.hs @@ -26,7 +26,7 @@ import Language.PureScript.CodeGen.Common import Language.PureScript.TypeClassDictionaries -import Language.PureScript.Declarations +import Language.PureScript.AST import Language.PureScript.Pretty import Language.PureScript.Names import Language.PureScript.Kinds @@ -87,8 +87,8 @@ case Qualified (Just moduleName) className `M.lookup` typeClasses env of Nothing -> error $ show className ++ " has no type class definition in exportToPs" Just (args, members, implies) -> do - let impliesString = if null implies - then "" + let impliesString = if null implies + then "" else "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) implies) ++ ") <= " typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing className)) (map toTypeVar args) tell ["class " ++ impliesString ++ typeName ++ " where"] diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -33,7 +33,7 @@ import Control.Arrow (second) import Language.PureScript.Names -import Language.PureScript.Declarations +import Language.PureScript.AST import Language.PureScript.Options import Language.PureScript.CodeGen.JS.AST as AST import Language.PureScript.Optimizer @@ -93,7 +93,7 @@ -- Generate code in the simplified Javascript intermediate representation for a declaration -- declToJs :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName -> Declaration -> Environment -> SupplyT m (Maybe [JS]) -declToJs opts mp (ValueDeclaration ident _ _ _ val) e = do +declToJs opts mp (ValueDeclaration ident _ _ (Right val)) e = do js <- valueToJs opts mp e val return $ Just [JSVariableIntroduction (identToJs ident) (Just js)] declToJs opts mp (BindingGroupDeclaration vals) e = do @@ -280,21 +280,25 @@ bindersToJs opts m e binders vals = do valNames <- replicateM (length vals) freshName let assignments = zipWith JSVariableIntroduction valNames (map Just vals) - jss <- forM binders $ \(CaseAlternative bs grd result) -> do - ret <- valueToJs opts m e result - go valNames [JSReturn ret] bs grd + jss <- forM binders $ \(CaseAlternative bs result) -> do + ret <- guardsToJs result + go valNames ret bs return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") $ [JSStringLiteral "Failed pattern match"]]))) [] where - go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder] -> Maybe Guard -> SupplyT m [JS] - go _ done [] Nothing = return done - go _ done [] (Just cond) = do - cond' <- valueToJs opts m e cond - return [JSIfElse cond' (JSBlock done) Nothing] - go (v:vs) done' (b:bs) grd = do - done'' <- go vs done' bs grd + go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder] -> SupplyT m [JS] + go _ done [] = return done + go (v:vs) done' (b:bs) = do + done'' <- go vs done' bs binderToJs m e v done'' b - go _ _ _ _ = error "Invalid arguments to bindersToJs" + go _ _ _ = error "Invalid arguments to bindersToJs" + + guardsToJs :: (Functor m, Applicative m, Monad m) => Either [(Guard, Expr)] Expr -> SupplyT m [JS] + guardsToJs (Left gs) = forM gs $ \(cond, val) -> do + cond' <- valueToJs opts m e cond + done <- valueToJs opts m e val + return $ JSIfElse cond' (JSBlock [JSReturn done]) Nothing + guardsToJs (Right v) = return . JSReturn <$> valueToJs opts m e v -- | -- Generate code in the simplified Javascript intermediate representation for a pattern match diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -153,6 +153,9 @@ 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 --- a/src/Language/PureScript/DeadCodeElimination.hs +++ b/src/Language/PureScript/DeadCodeElimination.hs @@ -21,7 +21,7 @@ import Data.Maybe (mapMaybe) import Language.PureScript.Names -import Language.PureScript.Declarations +import Language.PureScript.AST -- | -- Eliminate all declarations which are not a transitive dependency of the entry point module @@ -46,7 +46,7 @@ filterExport _ _ = Nothing valueExists :: Ident -> Declaration -> Bool - valueExists name (ValueDeclaration name' _ _ _ _) = name == name' + valueExists name (ValueDeclaration name' _ _ _) = name == name' valueExists name (ExternDeclaration _ name' _ _) = name == name' valueExists name (BindingGroupDeclaration decls) = any (\(name', _, _) -> name == name') decls valueExists name (PositionedDeclaration _ d) = valueExists name d @@ -65,7 +65,7 @@ declarationsByModule (Module moduleName ds _) = concatMap go ds where go :: Declaration -> [(Key, [Key])] - go d@(ValueDeclaration name _ _ _ _) = [((moduleName, Left name), dependencies moduleName d)] + go d@(ValueDeclaration name _ _ _) = [((moduleName, Left name), dependencies moduleName d)] go (DataDeclaration _ _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])] go d@(BindingGroupDeclaration names') = map (\(name, _, _) -> ((moduleName, Left name), dependencies moduleName d)) names' @@ -88,7 +88,7 @@ values _ = [] isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Declaration -> Bool -isUsed moduleName graph vertexFor entryPointVertices (ValueDeclaration name _ _ _ _) = +isUsed moduleName graph vertexFor entryPointVertices (ValueDeclaration name _ _ _) = let Just v' = vertexFor (moduleName, Left name) in any (\v -> path graph v v') entryPointVertices isUsed moduleName graph vertexFor entryPointVertices (FixityDeclaration _ name) = diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs deleted file mode 100644 --- a/src/Language/PureScript/Declarations.hs +++ /dev/null @@ -1,849 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Declarations --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | Data types for modules and declarations --- ------------------------------------------------------------------------------ - -{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} - -module Language.PureScript.Declarations where - -import Data.Monoid (Monoid(..), mconcat) - -import qualified Data.Data as D - -import Control.Applicative -import Control.Monad - -import Language.PureScript.Types -import Language.PureScript.Names -import Language.PureScript.Kinds -import Language.PureScript.TypeClassDictionaries -import Language.PureScript.CodeGen.JS.AST -import Language.PureScript.Environment -import Language.PureScript.Traversals - --- | --- A precedence level for an infix operator --- -type Precedence = Integer - --- | --- Associativity for infix operators --- -data Associativity = Infixl | Infixr | Infix deriving (D.Data, D.Typeable) - -instance Show Associativity where - show Infixl = "infixl" - show Infixr = "infixr" - show Infix = "infix" - --- | --- Source position information --- -data SourcePos = SourcePos - { -- | - -- Source name - -- - sourceName :: String - -- | - -- Line number - -- - , sourcePosLine :: Int - -- | - -- Column number - -- - , sourcePosColumn :: Int - } deriving (D.Data, D.Typeable) - -instance Show SourcePos where - show sp = (sourceName sp) ++ " line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp) - --- | --- Fixity data for infix operators --- -data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable) - --- | --- A module declaration, consisting of a module name, a list of declarations, and a list of the --- declarations that are explicitly exported. If the export list is Nothing, everything is exported. --- -data Module = Module ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable) - --- | --- An item in a list of explicit imports or exports --- -data DeclarationRef - -- | - -- A type constructor with data constructors - -- - = TypeRef ProperName (Maybe [ProperName]) - -- | - -- A value - -- - | ValueRef Ident - -- | - -- A type class - -- - | TypeClassRef ProperName - -- | - -- A type class instance, created during typeclass desugaring (name, class name, instance types) - -- - | TypeInstanceRef Ident - -- | - -- A declaration reference with source position information - -- - | PositionedDeclarationRef SourcePos DeclarationRef - deriving (Show, D.Data, D.Typeable) - -instance Eq DeclarationRef where - (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors' - (ValueRef name) == (ValueRef name') = name == name' - (TypeClassRef name) == (TypeClassRef name') = name == name' - (TypeInstanceRef name) == (TypeInstanceRef name') = name == name' - (PositionedDeclarationRef _ r) == r' = r == r' - r == (PositionedDeclarationRef _ r') = r == r' - _ == _ = False - --- | --- The data type which specifies type of import declaration --- -data ImportDeclarationType - -- | - -- Unqualified import - -- - = Unqualified - -- | - -- Qualified import with a list of references to import - -- - | Qualifying [DeclarationRef] - -- | - -- Import with hiding clause with a list of references to hide - -- - | Hiding [DeclarationRef] - deriving (Show, D.Data, D.Typeable) - --- | --- The data type of declarations --- -data Declaration - -- | - -- A data type declaration (data or newtype, name, arguments, data constructors) - -- - = DataDeclaration DataDeclType ProperName [(String, Maybe Kind)] [(ProperName, [Type])] - -- | - -- A minimal mutually recursive set of data type declarations - -- - | DataBindingGroupDeclaration [Declaration] - -- | - -- A type synonym declaration (name, arguments, type) - -- - | TypeSynonymDeclaration ProperName [(String, Maybe Kind)] Type - -- | - -- A type declaration for a value (name, ty) - -- - | TypeDeclaration Ident Type - -- | - -- A value declaration (name, top-level binders, optional guard, value) - -- - | ValueDeclaration Ident NameKind [Binder] (Maybe Guard) Expr - -- | - -- A minimal mutually recursive set of value declarations - -- - | BindingGroupDeclaration [(Ident, NameKind, Expr)] - -- | - -- A foreign import declaration (type, name, optional inline Javascript, type) - -- - | ExternDeclaration ForeignImportType Ident (Maybe JS) Type - -- | - -- A data type foreign import (name, kind) - -- - | ExternDataDeclaration ProperName Kind - -- | - -- A type class instance foreign import - -- - | ExternInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] - -- | - -- A fixity declaration (fixity data, operator name) - -- - | FixityDeclaration Fixity String - -- | - -- A module import (module name, optional set of identifiers to import, - -- optional set of identifiers to hide, optional "qualified as" name) - -- - | ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName) - -- | - -- A type class declaration (name, argument, implies, member declarations) - -- - | TypeClassDeclaration ProperName [(String, Maybe Kind)] [(Qualified ProperName, [Type])] [Declaration] - -- | - -- A type instance declaration (name, dependencies, class name, instance types, member - -- declarations) - -- - | TypeInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] [Declaration] - -- | - -- A declaration with source position information - -- - | PositionedDeclaration SourcePos Declaration - deriving (Show, D.Data, D.Typeable) - --- | --- Test if a declaration is a value declaration --- -isValueDecl :: Declaration -> Bool -isValueDecl ValueDeclaration{} = True -isValueDecl (PositionedDeclaration _ d) = isValueDecl d -isValueDecl _ = False - --- | --- Test if a declaration is a data type or type synonym declaration --- -isDataDecl :: Declaration -> Bool -isDataDecl DataDeclaration{} = True -isDataDecl TypeSynonymDeclaration{} = True -isDataDecl (PositionedDeclaration _ d) = isDataDecl d -isDataDecl _ = False - --- | --- Test if a declaration is a module import --- -isImportDecl :: Declaration -> Bool -isImportDecl ImportDeclaration{} = True -isImportDecl (PositionedDeclaration _ d) = isImportDecl d -isImportDecl _ = False - --- | --- Test if a declaration is a data type foreign import --- -isExternDataDecl :: Declaration -> Bool -isExternDataDecl ExternDataDeclaration{} = True -isExternDataDecl (PositionedDeclaration _ d) = isExternDataDecl d -isExternDataDecl _ = False - --- | --- Test if a declaration is a type class instance foreign import --- -isExternInstanceDecl :: Declaration -> Bool -isExternInstanceDecl ExternInstanceDeclaration{} = True -isExternInstanceDecl (PositionedDeclaration _ d) = isExternInstanceDecl d -isExternInstanceDecl _ = False - --- | --- Test if a declaration is a fixity declaration --- -isFixityDecl :: Declaration -> Bool -isFixityDecl FixityDeclaration{} = True -isFixityDecl (PositionedDeclaration _ d) = isFixityDecl d -isFixityDecl _ = False - --- | --- Test if a declaration is a foreign import --- -isExternDecl :: Declaration -> Bool -isExternDecl ExternDeclaration{} = True -isExternDecl (PositionedDeclaration _ d) = isExternDecl d -isExternDecl _ = False - --- | --- Test if a declaration is a type class or instance declaration --- -isTypeClassDeclaration :: Declaration -> Bool -isTypeClassDeclaration TypeClassDeclaration{} = True -isTypeClassDeclaration TypeInstanceDeclaration{} = True -isTypeClassDeclaration (PositionedDeclaration _ d) = isTypeClassDeclaration d -isTypeClassDeclaration _ = False - --- | --- A guard is just a boolean-valued expression that appears alongside a set of binders --- -type Guard = Expr - --- | --- Data type for expressions and terms --- -data Expr - -- | - -- A numeric literal - -- - = NumericLiteral (Either Integer Double) - -- | - -- A string literal - -- - | StringLiteral String - -- | - -- A boolean literal - -- - | BooleanLiteral Bool - -- | - -- A prefix -, will be desugared - -- - | UnaryMinus Expr - -- | - -- Binary operator application. During the rebracketing phase of desugaring, this data constructor - -- will be removed. - -- - | BinaryNoParens (Qualified Ident) Expr Expr - -- | - -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor - -- will be removed. - -- - | Parens Expr - -- | - -- An array literal - -- - | ArrayLiteral [Expr] - -- | - -- An object literal - -- - | ObjectLiteral [(String, Expr)] - -- | - -- An record property accessor expression - -- - | Accessor String Expr - -- | - -- Partial record update - -- - | ObjectUpdate Expr [(String, Expr)] - -- | - -- Function introduction - -- - | Abs (Either Ident Binder) Expr - -- | - -- Function application - -- - | App Expr Expr - -- | - -- Variable - -- - | Var (Qualified Ident) - -- | - -- Conditional (if-then-else expression) - -- - | IfThenElse Expr Expr Expr - -- | - -- A data constructor - -- - | Constructor (Qualified ProperName) - -- | - -- A case expression. During the case expansion phase of desugaring, top-level binders will get - -- desugared into case expressions, hence the need for guards and multiple binders per branch here. - -- - | Case [Expr] [CaseAlternative] - -- | - -- A value with a type annotation - -- - | TypedValue Bool Expr Type - -- | - -- A let binding - -- - | Let [Declaration] Expr - -- | - -- A do-notation block - -- - | Do [DoNotationElement] - -- | - -- An application of a typeclass dictionary constructor. The value should be - -- an ObjectLiteral. - -- - | TypeClassDictionaryConstructorApp (Qualified ProperName) Expr - -- | - -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these - -- placeholders will be replaced with actual expressions representing type classes dictionaries which - -- can be evaluated at runtime. The constructor arguments represent (in order): whether or not to look - -- at superclass implementations when searching for a dictionary, the type class name and - -- instance type, and the type class dictionaries in scope. - -- - | TypeClassDictionary Bool (Qualified ProperName, [Type]) [TypeClassDictionaryInScope] - -- | - -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking - -- - | SuperClassDictionary (Qualified ProperName) [Type] - -- | - -- A value with source position information - -- - | PositionedValue SourcePos Expr deriving (Show, D.Data, D.Typeable) - --- | --- An alternative in a case statement --- -data CaseAlternative = CaseAlternative - { -- | - -- A collection of binders with which to match the inputs - -- - caseAlternativeBinders :: [Binder] - -- | - -- An optional guard - -- - , caseAlternativeGuard :: Maybe Guard - -- | - -- The result expression - -- - , caseAlternativeResult :: Expr - } deriving (Show, D.Data, D.Typeable) - --- | --- Find the original dictionary which a type class dictionary in scope refers to --- -canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident -canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm -canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm - --- | --- A statement in a do-notation block --- -data DoNotationElement - -- | - -- A monadic value without a binder - -- - = DoNotationValue Expr - -- | - -- A monadic value with a binder - -- - | DoNotationBind Binder Expr - -- | - -- A let statement, i.e. a pure value with a binder - -- - | DoNotationLet [Declaration] - -- | - -- A do notation element with source position information - -- - | PositionedDoNotationElement SourcePos DoNotationElement deriving (Show, D.Data, D.Typeable) - --- | --- Data type for binders --- -data Binder - -- | - -- Wildcard binder - -- - = NullBinder - -- | - -- A binder which matches a boolean literal - -- - | BooleanBinder Bool - -- | - -- A binder which matches a string literal - -- - | StringBinder String - -- | - -- A binder which matches a numeric literal - -- - | NumberBinder (Either Integer Double) - -- | - -- A binder which binds an identifier - -- - | VarBinder Ident - -- | - -- A binder which matches a data constructor - -- - | ConstructorBinder (Qualified ProperName) [Binder] - -- | - -- A binder which matches a record and binds its properties - -- - | ObjectBinder [(String, Binder)] - -- | - -- A binder which matches an array and binds its elements - -- - | ArrayBinder [Binder] - -- | - -- A binder which matches an array and binds its head and tail - -- - | ConsBinder Binder Binder - -- | - -- A binder which binds its input to an identifier - -- - | NamedBinder Ident Binder - -- | - -- A binder with source position information - -- - | PositionedBinder SourcePos Binder deriving (Show, D.Data, D.Typeable) - --- | --- Collect all names introduced in binders in an expression --- -binderNames :: Binder -> [Ident] -binderNames = go [] - where - go ns (VarBinder name) = name : ns - go ns (ConstructorBinder _ bs) = foldl go ns bs - go ns (ObjectBinder bs) = foldl go ns (map snd bs) - go ns (ArrayBinder bs) = foldl go ns bs - go ns (ConsBinder b1 b2) = go (go ns b1) b2 - go ns (NamedBinder name b) = go (name : ns) b - go ns (PositionedBinder _ b) = go ns b - go ns _ = ns - --- --- Traversals --- - -everywhereOnValues :: (Declaration -> Declaration) -> - (Expr -> Expr) -> - (Binder -> Binder) -> - (Declaration -> Declaration, Expr -> Expr, Binder -> Binder) -everywhereOnValues f g h = (f', g', h') - where - f' :: Declaration -> Declaration - f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (map f' ds)) - f' (ValueDeclaration name nameKind bs grd val) = f (ValueDeclaration name nameKind (map h' bs) (fmap g' grd) (g' val)) - f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds)) - f' (TypeClassDeclaration name args implies ds) = f (TypeClassDeclaration name args implies (map f' ds)) - f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (map f' ds)) - f' (PositionedDeclaration pos d) = f (PositionedDeclaration pos (f' d)) - f' other = f other - - g' :: Expr -> Expr - g' (UnaryMinus v) = g (UnaryMinus (g' v)) - g' (BinaryNoParens op v1 v2) = g (BinaryNoParens op (g' v1) (g' v2)) - g' (Parens v) = g (Parens (g' v)) - g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs)) - g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs)) - g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v)) - g' (Accessor prop v) = g (Accessor prop (g' v)) - g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs)) - g' (Abs name v) = g (Abs name (g' v)) - g' (App v1 v2) = g (App (g' v1) (g' v2)) - g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3)) - g' (Case vs alts) = g (Case (map g' vs) (map handleCaseAlternative alts)) - g' (TypedValue check v ty) = g (TypedValue check (g' v) ty) - g' (Let ds v) = g (Let (map f' ds) (g' v)) - g' (Do es) = g (Do (map handleDoNotationElement es)) - g' (PositionedValue pos v) = g (PositionedValue pos (g' v)) - g' other = g other - - h' :: Binder -> Binder - h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs)) - h' (ObjectBinder bs) = h (ObjectBinder (map (fmap h') bs)) - h' (ArrayBinder bs) = h (ArrayBinder (map h' bs)) - h' (ConsBinder b1 b2) = h (ConsBinder (h' b1) (h' b2)) - h' (NamedBinder name b) = h (NamedBinder name (h' b)) - h' (PositionedBinder pos b) = h (PositionedBinder pos (h' b)) - h' other = h other - - handleCaseAlternative :: CaseAlternative -> CaseAlternative - handleCaseAlternative ca = - ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca) - , caseAlternativeGuard = fmap g' (caseAlternativeGuard ca) - , caseAlternativeResult = g' (caseAlternativeResult ca) - } - - handleDoNotationElement :: DoNotationElement -> DoNotationElement - handleDoNotationElement (DoNotationValue v) = DoNotationValue (g' v) - handleDoNotationElement (DoNotationBind b v) = DoNotationBind (h' b) (g' v) - handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds) - handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos (handleDoNotationElement e) - - -everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) => - (Declaration -> m Declaration) -> - (Expr -> m Expr) -> - (Binder -> m Binder) -> - (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder) -everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) - where - f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f' <=< f) ds - f' (ValueDeclaration name nameKind bs grd val) = ValueDeclaration name nameKind <$> mapM (h' <=< h) bs <*> maybeM (g' <=< g) grd <*> (g val >>= g') - f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds - f' (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f' <=< f) ds - f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f' <=< f) ds - f' (PositionedDeclaration pos d) = PositionedDeclaration pos <$> (f d >>= f') - f' other = f other - - g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g') - g' (BinaryNoParens op v1 v2) = BinaryNoParens op <$> (g v1 >>= g') <*> (g v2 >>= g') - g' (Parens v) = Parens <$> (g v >>= g') - g' (ArrayLiteral vs) = ArrayLiteral <$> mapM (g' <=< g) vs - g' (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g' <=< g)) vs - g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g') - g' (Accessor prop v) = Accessor prop <$> (g v >>= g') - g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> mapM (sndM (g' <=< g)) vs - g' (Abs name v) = Abs name <$> (g v >>= g') - g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g') - g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g') - g' (Case vs alts) = Case <$> mapM (g' <=< g) vs <*> mapM handleCaseAlternative alts - g' (TypedValue check v ty) = TypedValue check <$> (g v >>= g') <*> pure ty - g' (Let ds v) = Let <$> mapM (f' <=< f) ds <*> (g v >>= g') - g' (Do es) = Do <$> mapM handleDoNotationElement es - g' (PositionedValue pos v) = PositionedValue pos <$> (g v >>= g') - g' other = g other - - h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h' <=< h) bs - h' (ObjectBinder bs) = ObjectBinder <$> mapM (sndM (h' <=< h)) bs - h' (ArrayBinder bs) = ArrayBinder <$> mapM (h' <=< h) bs - h' (ConsBinder b1 b2) = ConsBinder <$> (h b1 >>= h') <*> (h b2 >>= h') - h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h') - h' (PositionedBinder pos b) = PositionedBinder pos <$> (h b >>= h') - h' other = h other - - handleCaseAlternative (CaseAlternative bs grd val) = CaseAlternative <$> mapM (h' <=< h) bs - <*> maybeM (g' <=< g) grd - <*> (g' <=< g) val - - handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v - handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v - handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM (f' <=< f) ds - handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos <$> handleDoNotationElement e - -everywhereOnValuesM :: (Functor m, Applicative m, Monad m) => - (Declaration -> m Declaration) -> - (Expr -> m Expr) -> - (Binder -> m Binder) -> - (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder) -everywhereOnValuesM f g h = (f' <=< f, g' <=< g, h' <=< h) - where - f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> mapM f' ds) >>= f - f' (ValueDeclaration name nameKind bs grd val) = (ValueDeclaration name nameKind <$> mapM h' bs <*> maybeM g' grd <*> g' val) >>= f - f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f - f' (TypeClassDeclaration name args implies ds) = (TypeClassDeclaration name args implies <$> mapM f' ds) >>= f - f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> mapM f' ds) >>= f - f' (PositionedDeclaration pos d) = (PositionedDeclaration pos <$> f' d) >>= f - f' other = f other - - g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g - g' (BinaryNoParens op v1 v2) = (BinaryNoParens op <$> (g' v1) <*> (g' v2)) >>= g - g' (Parens v) = (Parens <$> g' v) >>= g - g' (ArrayLiteral vs) = (ArrayLiteral <$> mapM g' vs) >>= g - g' (ObjectLiteral vs) = (ObjectLiteral <$> mapM (sndM g') vs) >>= g - g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g - g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g - g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> mapM (sndM g') vs) >>= g - g' (Abs name v) = (Abs name <$> g' v) >>= g - g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g - g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g - g' (Case vs alts) = (Case <$> mapM g' vs <*> mapM handleCaseAlternative alts) >>= g - g' (TypedValue check v ty) = (TypedValue check <$> g' v <*> pure ty) >>= g - g' (Let ds v) = (Let <$> mapM f' ds <*> g' v) >>= g - g' (Do es) = (Do <$> mapM handleDoNotationElement es) >>= g - g' (PositionedValue pos v) = (PositionedValue pos <$> g' v) >>= g - g' other = g other - - h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> mapM h' bs) >>= h - h' (ObjectBinder bs) = (ObjectBinder <$> mapM (sndM h') bs) >>= h - h' (ArrayBinder bs) = (ArrayBinder <$> mapM h' bs) >>= h - h' (ConsBinder b1 b2) = (ConsBinder <$> h' b1 <*> h' b2) >>= h - h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h - h' (PositionedBinder pos b) = (PositionedBinder pos <$> h' b) >>= h - h' other = h other - - handleCaseAlternative (CaseAlternative bs grd val) = CaseAlternative <$> mapM h' bs - <*> maybeM g' grd - <*> g' val - - handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v - handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v - handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM f' ds - handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos <$> handleDoNotationElement e - -everythingOnValues :: (r -> r -> r) -> - (Declaration -> r) -> - (Expr -> r) -> - (Binder -> r) -> - (CaseAlternative -> r) -> - (DoNotationElement -> r) -> - (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r) -everythingOnValues (<>) f g h i j = (f', g', h', i', j') - where - f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds) - f' d@(ValueDeclaration _ _ bs Nothing val) = foldl (<>) (f d) (map h' bs) <> g' val - f' d@(ValueDeclaration _ _ bs (Just grd) val) = foldl (<>) (f d) (map h' bs) <> g' grd <> g' val - f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds) - f' d@(TypeClassDeclaration _ _ _ ds) = foldl (<>) (f d) (map f' ds) - f' d@(TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds) - f' d@(PositionedDeclaration _ d1) = f d <> f' d1 - f' d = f d - - g' v@(UnaryMinus v1) = g v <> g' v1 - g' v@(BinaryNoParens _ v1 v2) = g v <> g' v1 <> g' v2 - g' v@(Parens v1) = g v <> g' v1 - g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs) - g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs) - g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1 - g' v@(Accessor _ v1) = g v <> g' v1 - g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs) - g' v@(Abs _ v1) = g v <> g' v1 - g' v@(App v1 v2) = g v <> g' v1 <> g' v2 - g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3 - g' v@(Case vs alts) = foldl (<>) (foldl (<>) (g v) (map g' vs)) (map i' alts) - g' v@(TypedValue _ v1 _) = g v <> g' v1 - g' v@(Let ds v1) = (foldl (<>) (g v) (map f' ds)) <> g' v1 - g' v@(Do es) = foldl (<>) (g v) (map j' es) - g' v@(PositionedValue _ v1) = g v <> g' v1 - g' v = g v - - h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs) - h' b@(ObjectBinder bs) = foldl (<>) (h b) (map (h' . snd) bs) - h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs) - h' b@(ConsBinder b1 b2) = h b <> h' b1 <> h' b2 - h' b@(NamedBinder _ b1) = h b <> h' b1 - h' b@(PositionedBinder _ b1) = h b <> h' b1 - h' b = h b - - i' ca = case caseAlternativeGuard ca of - Nothing -> foldl (<>) (i ca) (map h' (caseAlternativeBinders ca)) <> g' (caseAlternativeResult ca) - Just grd -> foldl (<>) (i ca) (map h' (caseAlternativeBinders ca)) <> g' grd <> g' (caseAlternativeResult ca) - - j' e@(DoNotationValue v) = j e <> g' v - j' e@(DoNotationBind b v) = j e <> h' b <> g' v - j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds) - j' e@(PositionedDoNotationElement _ e1) = j e <> j' e1 - -everythingWithContextOnValues :: - s -> - r -> - (r -> r -> r) -> - (s -> Declaration -> (s, r)) -> - (s -> Expr -> (s, r)) -> - (s -> Binder -> (s, r)) -> - (s -> CaseAlternative -> (s, r)) -> - (s -> DoNotationElement -> (s, r)) -> - ( Declaration -> r - , Expr -> r - , Binder -> r - , CaseAlternative -> r - , DoNotationElement -> r) -everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0) - where - f'' s d = let (s', r) = f s d in r <> f' s' d - - f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds) - f' s (ValueDeclaration _ _ bs Nothing val) = foldl (<>) r0 (map (h'' s) bs) <> (g'' s) val - f' s (ValueDeclaration _ _ bs (Just grd) val) = foldl (<>) r0 (map (h'' s) bs) <> (g'' s) grd <> (g'' s) val - f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> (g'' s) val) ds) - f' s (TypeClassDeclaration _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds) - f' s (TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds) - f' s (PositionedDeclaration _ d1) = (f'' s) d1 - f' _ _ = r0 - - g'' s v = let (s', r) = g s v in r <> g' s' v - - g' s (UnaryMinus v1) = (g'' s) v1 - g' s (BinaryNoParens _ v1 v2) = (g'' s) v1 <> (g'' s) v2 - g' s (Parens v1) = (g'' s) v1 - g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs) - g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs) - g' s (TypeClassDictionaryConstructorApp _ v1) = (g'' s) v1 - g' s (Accessor _ v1) = (g'' s) v1 - g' s (ObjectUpdate obj vs) = foldl (<>) ((g'' s) obj) (map (g'' s . snd) vs) - g' s (Abs _ v1) = (g'' s) v1 - g' s (App v1 v2) = (g'' s) v1 <> (g'' s) v2 - g' s (IfThenElse v1 v2 v3) = (g'' s) v1 <> (g'' s) v2 <> (g'' s) v3 - g' s (Case vs alts) = foldl (<>) (foldl (<>) r0 (map (g'' s) vs)) (map (i'' s) alts) - g' s (TypedValue _ v1 _) = (g'' s) v1 - g' s (Let ds v1) = (foldl (<>) r0 (map (f'' s) ds)) <> (g'' s) v1 - g' s (Do es) = foldl (<>) r0 (map (j'' s) es) - g' s (PositionedValue _ v1) = (g'' s) v1 - g' _ _ = r0 - - h'' s b = let (s', r) = h s b in r <> h' s' b - - h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs) - h' s (ObjectBinder bs) = foldl (<>) r0 (map (h'' s . snd) bs) - h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs) - h' s (ConsBinder b1 b2) = (h'' s) b1 <> (h'' s) b2 - h' s (NamedBinder _ b1) = (h'' s) b1 - h' s (PositionedBinder _ b1) = (h'' s) b1 - h' _ _ = r0 - - i'' s ca = let (s', r) = i s ca in r <> i' s' ca - - i' s (CaseAlternative bs Nothing val) = foldl (<>) r0 (map (h'' s) bs) <> (g'' s) val - i' s (CaseAlternative bs (Just grd) val) = foldl (<>) r0 (map (h'' s) bs) <> (g'' s) grd <> (g'' s) val - - j'' s e = let (s', r) = j s e in r <> j' s' e - - j' s (DoNotationValue v) = (g'' s) v - j' s (DoNotationBind b v) = (h'' s) b <> (g'' s) v - j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds) - j' s (PositionedDoNotationElement _ e1) = (j'' s) e1 - -everywhereWithContextOnValuesM :: (Functor m, Applicative m, Monad m) => - s -> - (s -> Declaration -> m (s, Declaration)) -> - (s -> Expr -> m (s, Expr)) -> - (s -> Binder -> m (s, Binder)) -> - (s -> CaseAlternative -> m (s, CaseAlternative)) -> - (s -> DoNotationElement -> m (s, DoNotationElement)) -> - ( Declaration -> m Declaration - , Expr -> m Expr - , Binder -> m Binder - , CaseAlternative -> m CaseAlternative - , DoNotationElement -> m DoNotationElement) -everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0) - where - f'' s = uncurry f' <=< f s - - f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f'' s) ds - f' s (ValueDeclaration name nameKind bs grd val) = ValueDeclaration name nameKind <$> mapM (h'' s) bs <*> maybeM (g'' s) grd <*> g'' s val - f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (thirdM (g'' s)) ds - f' s (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f'' s) ds - f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f'' s) ds - f' s (PositionedDeclaration pos d1) = PositionedDeclaration pos <$> f'' s d1 - f' _ other = return other - - g'' s = uncurry g' <=< g s - - g' s (UnaryMinus v) = UnaryMinus <$> g'' s v - g' s (BinaryNoParens op v1 v2) = BinaryNoParens op <$> g'' s v1 <*> g'' s v2 - g' s (Parens v) = Parens <$> g'' s v - g' s (ArrayLiteral vs) = ArrayLiteral <$> mapM (g'' s) vs - g' s (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g'' s)) vs - g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g'' s) v - g' s (Accessor prop v) = Accessor prop <$> g'' s v - g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> mapM (sndM (g'' s)) vs - g' s (Abs name v) = Abs name <$> g'' s v - g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2 - g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3 - g' s (Case vs alts) = Case <$> mapM (g'' s) vs <*> mapM (i'' s) alts - g' s (TypedValue check v ty) = TypedValue check <$> g'' s v <*> pure ty - g' s (Let ds v) = Let <$> mapM (f'' s) ds <*> g'' s v - g' s (Do es) = Do <$> mapM (j'' s) es - g' s (PositionedValue pos v) = PositionedValue pos <$> g'' s v - g' _ other = return other - - h'' s = uncurry h' <=< h s - - h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h'' s) bs - h' s (ObjectBinder bs) = ObjectBinder <$> mapM (sndM (h'' s)) bs - h' s (ArrayBinder bs) = ArrayBinder <$> mapM (h'' s) bs - h' s (ConsBinder b1 b2) = ConsBinder <$> h'' s b1 <*> h'' s b2 - h' s (NamedBinder name b) = NamedBinder name <$> h'' s b - h' s (PositionedBinder pos b) = PositionedBinder pos <$> h'' s b - h' _ other = return other - - i'' s = uncurry i' <=< i s - - i' s (CaseAlternative bs grd val) = CaseAlternative <$> mapM (h'' s) bs <*> maybeM (g'' s) grd <*> g'' s val - - j'' s = uncurry j' <=< j s - - j' s (DoNotationValue v) = DoNotationValue <$> g'' s v - j' s (DoNotationBind b v) = DoNotationBind <$> h'' s b <*> g'' s v - j' s (DoNotationLet ds) = DoNotationLet <$> mapM (f'' s) ds - j' s (PositionedDoNotationElement pos e1) = PositionedDoNotationElement pos <$> j'' s e1 - -accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r) -accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty) - where - forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors) - forDecls (ExternDeclaration _ _ _ ty) = f ty - forDecls (ExternInstanceDeclaration _ cs _ tys) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys) - forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . snd) implies) - forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys) - forDecls (TypeSynonymDeclaration _ _ ty) = f ty - forDecls (TypeDeclaration _ ty) = f ty - forDecls _ = mempty - - forValues (TypeClassDictionary _ (_, cs) _) = mconcat (map f cs) - forValues (SuperClassDictionary _ tys) = mconcat (map f tys) - forValues (TypedValue _ _ ty) = f ty - forValues _ = mempty - - diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -23,7 +23,7 @@ import Control.Monad.Error import Control.Applicative ((<$>)) -import Language.PureScript.Declarations +import Language.PureScript.AST import Language.PureScript.Pretty import Language.PureScript.Types diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -21,7 +21,7 @@ import Data.List (nub) import Data.Maybe (mapMaybe) -import Language.PureScript.Declarations +import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Types diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -134,6 +134,12 @@ identifier = PT.identifier tokenParser -- | +-- Parse an identifier in a more permissive position +-- +identifierName :: P.Parsec String u String +identifierName = lexeme $ (:) <$> identStart <*> many identLetter + +-- | -- Parse a reserved word -- reserved :: String -> P.Parsec String u () diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -35,7 +35,7 @@ import Language.PureScript.Kinds import Language.PureScript.Parser.State import Language.PureScript.Parser.Common -import Language.PureScript.Declarations +import Language.PureScript.AST import Language.PureScript.Parser.Types import Language.PureScript.Parser.Kinds import Language.PureScript.CodeGen.JS.AST @@ -54,7 +54,7 @@ toSourcePos p = SourcePos (P.sourceName p) (P.sourceLine p) (P.sourceColumn p) kindedIdent :: P.Parsec String ParseState (String, Maybe Kind) -kindedIdent = (, Nothing) <$> identifier +kindedIdent = (, Nothing) <$> identifier <|> parens ((,) <$> identifier <*> (Just <$> (indented *> lexeme (P.string "::") *> indented *> parseKind))) parseDataDeclaration :: P.Parsec String ParseState Declaration @@ -64,7 +64,7 @@ tyArgs <- many (indented *> kindedIdent) ctors <- P.option [] $ do _ <- lexeme $ indented *> P.char '=' - sepBy1 ((,) <$> properName <*> P.many (indented *> parseTypeAtom)) pipe + sepBy1 ((,) <$> properName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe return $ DataDeclaration dtype name tyArgs ctors parseTypeDeclaration :: P.Parsec String ParseState Declaration @@ -76,20 +76,28 @@ parseTypeSynonymDeclaration = TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName) <*> many (indented *> kindedIdent) - <*> (lexeme (indented *> P.char '=') *> parsePolyType) + <*> (lexeme (indented *> P.char '=') *> noWildcards parsePolyType) parseValueDeclaration :: P.Parsec String ParseState Declaration parseValueDeclaration = do name <- parseIdent binders <- P.many parseBinderNoParens - guard <- P.optionMaybe parseGuard - value <- lexeme (indented *> P.char '=') *> parseValue - whereClause <- P.optionMaybe $ do - C.indented - reserved "where" - C.indented - C.mark $ P.many1 (C.same *> parseLocalDeclaration) - return $ ValueDeclaration name Value binders guard (maybe value (`Let` value) whereClause) + value <- Left <$> (C.indented *> + C.mark (P.many1 ((,) <$> (C.same *> parseGuard) + <*> (lexeme (indented *> P.char '=') *> parseValueWithWhereClause) + ))) + <|> Right <$> (lexeme (indented *> P.char '=') *> parseValueWithWhereClause) + return $ ValueDeclaration name Value binders value + where + parseValueWithWhereClause :: P.Parsec String ParseState Expr + parseValueWithWhereClause = do + value <- parseValue + whereClause <- P.optionMaybe $ do + C.indented + reserved "where" + C.indented + C.mark $ P.many1 (C.same *> parseLocalDeclaration) + return $ maybe value (`Let` value) whereClause parseExternDeclaration :: P.Parsec String ParseState Declaration parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *> @@ -98,16 +106,16 @@ <|> (do reserved "instance" name <- parseIdent <* lexeme (indented *> P.string "::") deps <- P.option [] $ do - deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom)) + deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom))) indented reservedOp "=>" return deps className <- indented *> parseQualified properName - tys <- P.many (indented *> parseTypeAtom) + tys <- P.many (indented *> noWildcards parseTypeAtom) return $ ExternInstanceDeclaration name deps className tys) <|> (do ident <- parseIdent js <- P.optionMaybe (JSRaw <$> stringLiteral) - ty <- lexeme (indented *> P.string "::") *> parsePolyType + ty <- lexeme (indented *> P.string "::") *> noWildcards parsePolyType return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty)) parseAssociativity :: P.Parsec String ParseState Associativity @@ -168,7 +176,7 @@ reserved "class" implies <- P.option [] $ do indented - implies <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom)) + implies <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom))) reservedOp "<=" return implies className <- indented *> properName @@ -183,12 +191,12 @@ reserved "instance" name <- parseIdent <* lexeme (indented *> P.string "::") deps <- P.optionMaybe $ do - deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom)) + deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom))) indented reservedOp "=>" return deps className <- indented *> parseQualified properName - ty <- P.many (indented *> parseTypeAtom) + ty <- P.many (indented *> (noWildcards parseTypeAtom)) members <- P.option [] . P.try $ do indented *> reserved "where" mark (P.many (same *> positioned parseValueDeclaration)) @@ -233,10 +241,10 @@ return $ Module name decls exports -- | --- Parse a collection of modules +-- Parse a collection of modules -- parseModulesFromFiles :: (k -> String) -> [(k, String)] -> Either P.ParseError [(k, Module)] -parseModulesFromFiles toFilePath input = +parseModulesFromFiles toFilePath input = fmap collect . forM input $ \(filename, content) -> do ms <- runIndentParser (toFilePath filename) parseModules content return (filename, ms) @@ -269,7 +277,7 @@ parseObjectLiteral = ObjectLiteral <$> C.braces (C.commaSep parseIdentifierAndValue) parseIdentifierAndValue :: P.Parsec String ParseState (String, Expr) -parseIdentifierAndValue = (,) <$> (C.indented *> (C.identifier <|> C.stringLiteral) <* C.indented <* C.colon) +parseIdentifierAndValue = (,) <$> (C.indented *> (C.identifierName <|> C.stringLiteral) <* C.indented <* C.colon) <*> (C.indented *> parseValue) parseAbs :: P.Parsec String ParseState Expr @@ -295,8 +303,11 @@ parseCaseAlternative :: P.Parsec String ParseState CaseAlternative parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder) - <*> P.optionMaybe parseGuard - <*> (C.indented *> C.reservedOp "->" *> parseValue) + <*> (Left <$> (C.indented *> + C.mark (P.many1 ((,) <$> (C.same *> parseGuard) + <*> (lexeme (indented *> C.reservedOp "->") *> parseValue) + ))) + <|> Right <$> (lexeme (indented *> C.reservedOp "->") *> parseValue)) P. "case alternative" parseIfThenElse :: P.Parsec String ParseState Expr @@ -332,14 +343,14 @@ parsePropertyUpdate :: P.Parsec String ParseState (String, Expr) parsePropertyUpdate = do - name <- C.lexeme (C.identifier <|> C.stringLiteral) + name <- C.lexeme (C.identifierName <|> C.stringLiteral) _ <- C.lexeme $ C.indented *> P.char '=' value <- C.indented *> parseValue return (name, value) parseAccessor :: Expr -> P.Parsec String ParseState Expr parseAccessor (Constructor _) = P.unexpected "constructor" -parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> (C.identifier <|> C.stringLiteral)) <*> pure obj +parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> (C.identifierName <|> C.stringLiteral)) <*> pure obj parseDo :: P.Parsec String ParseState Expr parseDo = do @@ -419,7 +430,7 @@ parseIdentifierAndBinder :: P.Parsec String ParseState (String, Binder) parseIdentifierAndBinder = do - name <- C.lexeme (C.identifier <|> C.stringLiteral) + name <- C.lexeme (C.identifierName <|> C.stringLiteral) _ <- C.lexeme $ C.indented *> P.char '=' binder <- C.indented *> parseBinder return (name, binder) @@ -464,6 +475,6 @@ -- Parse a guard -- parseGuard :: P.Parsec String ParseState Guard -parseGuard = C.indented *> C.pipe *> C.indented *> parseValue +parseGuard = C.pipe *> C.indented *> parseValue diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs --- 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 @@ parseObject :: P.Parsec String ParseState Type parseObject = braces $ TypeApp tyObject <$> parseRow +parseTypeWildcard :: P.Parsec String ParseState Type +parseTypeWildcard = lexeme (P.char '_') >> return TypeWildcard + parseTypeVariable :: P.Parsec String ParseState Type parseTypeVariable = do ident <- identifier @@ -65,6 +69,7 @@ , parseArrayOf , parseFunction , parseObject + , parseTypeWildcard , parseTypeVariable , parseTypeConstructor , parseForAll @@ -108,8 +113,17 @@ parsePolyType :: P.Parsec String ParseState Type parsePolyType = parseAnyType +-- | +-- Parse an atomic type with no wildcards +-- +noWildcards :: P.Parsec String ParseState Type -> P.Parsec String ParseState Type +noWildcards p = do + ty <- p + when (containsWildcards ty) $ P.unexpected "type wildcard" + return ty + parseNameAndType :: P.Parsec String ParseState t -> P.Parsec String ParseState (String, t) -parseNameAndType p = (,) <$> (indented *> (identifier <|> stringLiteral) <* indented <* lexeme (P.string "::")) <*> p +parseNameAndType p = (,) <$> (indented *> (identifierName <|> stringLiteral) <* indented <* lexeme (P.string "::")) <*> p parseRowEnding :: P.Parsec String ParseState Type parseRowEnding = P.option REmpty (TypeVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier)) diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -34,6 +34,7 @@ typeLiterals :: Pattern () Type String typeLiterals = mkPattern match where + match TypeWildcard = Just "_" match (TypeVar var) = Just var match (PrettyPrintObject row) = Just $ "{ " ++ prettyPrintRow row ++ " }" match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]" diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -26,7 +26,7 @@ import Control.Monad.State import Control.Applicative -import Language.PureScript.Declarations +import Language.PureScript.AST import Language.PureScript.Pretty.Common import Language.PureScript.Pretty.Types (prettyPrintType) @@ -86,7 +86,7 @@ prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String prettyPrintDeclaration (TypeDeclaration ident ty) = return $ show ident ++ " :: " ++ prettyPrintType ty -prettyPrintDeclaration (ValueDeclaration ident _ [] Nothing val) = fmap concat $ sequence +prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) = fmap concat $ sequence [ return $ show ident ++ " = " , prettyPrintValue' val ] @@ -94,13 +94,23 @@ prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration" prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String -prettyPrintCaseAlternative (CaseAlternative binders grd val) = +prettyPrintCaseAlternative (CaseAlternative binders result) = fmap concat $ sequence [ intercalate ", " <$> forM binders prettyPrintBinder' - , maybe (return "") (fmap ("| " ++) . prettyPrintValue') grd - , return " -> " - , prettyPrintValue' val + , prettyPrintResult result ] + where + prettyPrintResult (Left gs) = concat <$> mapM prettyPrintGuardedValue gs + prettyPrintResult (Right v) = (" -> " ++) <$> prettyPrintValue' v + + prettyPrintGuardedValue (grd, val) = + fmap concat $ sequence + [ return "| " + , prettyPrintValue' grd + , return " -> " + , prettyPrintValue' val + , return "\n" + ] prettyPrintDoNotationElement :: DoNotationElement -> StateT PrinterState Maybe String prettyPrintDoNotationElement (DoNotationValue val) = diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -23,7 +23,7 @@ import qualified Data.Map as M import qualified Data.Set as S -import Language.PureScript.Declarations +import Language.PureScript.AST import Language.PureScript.Environment import Language.PureScript.Names import Language.PureScript.Traversals @@ -103,7 +103,7 @@ findDeclIdents :: [Declaration] -> [Ident] findDeclIdents = concatMap go where - go (ValueDeclaration ident _ _ _ _) = [ident] + go (ValueDeclaration ident _ _ _) = [ident] go (BindingGroupDeclaration ds) = map (\(name, _, _) -> name) ds go (ExternDeclaration _ ident _ _) = [ident] go (TypeClassDeclaration _ _ _ ds) = findDeclIdents ds @@ -129,9 +129,9 @@ -- another in the current scope. -- renameInDecl :: Bool -> Declaration -> Rename Declaration -renameInDecl isTopLevel (ValueDeclaration name nameKind [] Nothing val) = do +renameInDecl isTopLevel (ValueDeclaration name nameKind [] (Right val)) = do name' <- if isTopLevel then return name else updateScope name - ValueDeclaration name' nameKind [] Nothing <$> renameInValue val + ValueDeclaration name' nameKind [] . Right <$> renameInValue val renameInDecl isTopLevel (BindingGroupDeclaration ds) = do ds' <- mapM updateNames ds BindingGroupDeclaration <$> mapM updateValues ds' @@ -187,8 +187,9 @@ -- Renames within case alternatives. -- renameInCaseAlternative :: CaseAlternative -> Rename CaseAlternative -renameInCaseAlternative (CaseAlternative bs g v) = - CaseAlternative <$> mapM renameInBinder bs <*> maybeM renameInValue g <*> renameInValue v +renameInCaseAlternative (CaseAlternative bs v) = + CaseAlternative <$> mapM renameInBinder bs + <*> eitherM (mapM (pairM renameInValue renameInValue)) renameInValue v -- | -- Renames within binders. diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -19,7 +19,7 @@ import Control.Category ((>>>)) import Control.Monad.Trans.Class -import Language.PureScript.Declarations +import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Supply diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -29,7 +29,7 @@ import qualified Data.Set as S -import Language.PureScript.Declarations +import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Types import Language.PureScript.Environment @@ -84,7 +84,7 @@ collapseBindingGroups = let (f, _, _) = everywhereOnValues id collapseBindingGroupsForValue id in map f . concatMap go where go (DataBindingGroupDeclaration ds) = ds - go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] Nothing val) ds + go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds go (PositionedDeclaration pos d) = map (PositionedDeclaration pos) $ go d go other = [other] @@ -98,13 +98,13 @@ in nub . f where def s _ = (s, []) - + usedNamesE :: S.Set Ident -> Expr -> (S.Set Ident, [Ident]) usedNamesE scope (Var (Qualified Nothing name)) | name `S.notMember` scope = (scope, [name]) usedNamesE scope (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' && name `S.notMember` scope = (scope, [name]) usedNamesE scope (Abs (Left name) _) = (name `S.insert` scope, []) usedNamesE scope _ = (scope, []) - + usedNamesB :: S.Set Ident -> Binder -> (S.Set Ident, [Ident]) usedNamesB scope binder = (scope `S.union` S.fromList (binderNames binder), []) @@ -114,7 +114,7 @@ in nub . f where def s _ = (s, []) - + usedNamesE :: Bool -> Expr -> (Bool, [Ident]) usedNamesE True (Var (Qualified Nothing name)) = (True, [name]) usedNamesE True (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = (True, [name]) @@ -135,7 +135,7 @@ usedNames _ = [] getIdent :: Declaration -> Ident -getIdent (ValueDeclaration ident _ _ _ _) = ident +getIdent (ValueDeclaration ident _ _ _) = ident getIdent (PositionedDeclaration _ d) = getIdent d getIdent _ = error "Expected ValueDeclaration" @@ -147,8 +147,8 @@ -- | -- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration). --- -- +-- toBindingGroup :: ModuleName -> SCC Declaration -> Either ErrorStack Declaration toBindingGroup _ (AcyclicSCC d) = return d toBindingGroup _ (CyclicSCC [d]) = return d @@ -176,7 +176,7 @@ cycleError :: Declaration -> [Declaration] -> Either ErrorStack a cycleError (PositionedDeclaration p d) ds = rethrowWithPosition p $ cycleError d ds - cycleError (ValueDeclaration n _ _ _ e) [] = Left $ + cycleError (ValueDeclaration n _ _ (Right e)) [] = Left $ mkErrorStack ("Cycle in definition of " ++ show n) (Just (ExprError e)) cycleError d ds@(_:_) = rethrow (<> mkErrorStack ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing) $ cycleError d [] cycleError _ _ = error "Expected ValueDeclaration" @@ -197,7 +197,7 @@ isTypeSynonym _ = Nothing fromValueDecl :: Declaration -> (Ident, NameKind, Expr) -fromValueDecl (ValueDeclaration ident nameKind [] Nothing val) = (ident, nameKind, val) +fromValueDecl (ValueDeclaration ident nameKind [] (Right val)) = (ident, nameKind, val) fromValueDecl ValueDeclaration{} = error "Binders should have been desugared" fromValueDecl (PositionedDeclaration _ d) = fromValueDecl d fromValueDecl _ = error "Expected ValueDeclaration" diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -19,7 +19,7 @@ desugarCasesModule ) where -import Data.Maybe (isJust) +import Data.Either (isLeft) import Data.Monoid ((<>)) import Data.List (nub, groupBy) @@ -28,10 +28,11 @@ import Control.Monad.Error.Class import Language.PureScript.Names -import Language.PureScript.Declarations +import Language.PureScript.AST import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Supply +import Language.PureScript.Traversals import Language.PureScript.TypeChecker.Monad (guardWith) -- | @@ -50,7 +51,7 @@ replace :: Expr -> SupplyT (Either ErrorStack) Expr replace (Abs (Right binder) val) = do ident <- Ident <$> freshName - return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing val] + return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)] replace other = return other -- | @@ -62,9 +63,11 @@ desugarRest :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration] desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) = (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest - desugarRest (ValueDeclaration name nameKind bs g val : rest) = + desugarRest (ValueDeclaration name nameKind bs result : rest) = let (_, f, _) = everywhereOnValuesTopDownM return go return - in (:) <$> (ValueDeclaration name nameKind bs g <$> f val) <*> desugarRest rest + f' (Left gs) = Left <$> mapM (pairM return f) gs + f' (Right v) = Right <$> f v + in (:) <$> (ValueDeclaration name nameKind bs <$> f' result) <*> desugarRest rest where go (Let ds val') = Let <$> desugarCases ds <*> pure val' go other = return other @@ -75,22 +78,22 @@ desugarRest [] = pure [] inSameGroup :: Declaration -> Declaration -> Bool -inSameGroup (ValueDeclaration ident1 _ _ _ _) (ValueDeclaration ident2 _ _ _ _) = ident1 == ident2 +inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2 inSameGroup (PositionedDeclaration _ d1) d2 = inSameGroup d1 d2 inSameGroup d1 (PositionedDeclaration _ d2) = inSameGroup d1 d2 inSameGroup _ _ = False toDecls :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration] -toDecls [ValueDeclaration ident nameKind bs Nothing val] | all isVarBinder bs = do +toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = do let args = map (\(VarBinder arg) -> arg) bs body = foldr (Abs . Left) val args guardWith (strMsg "Overlapping function argument names") $ length (nub args) == length args - return [ValueDeclaration ident nameKind [] Nothing body] -toDecls ds@(ValueDeclaration ident _ bs g _ : _) = do + return [ValueDeclaration ident nameKind [] (Right body)] +toDecls ds@(ValueDeclaration ident _ bs result : _) = do let tuples = map toTuple ds unless (all ((== length bs) . length . fst) tuples) $ throwError $ mkErrorStack ("Argument list lengths differ in declaration " ++ show ident) Nothing - unless (not (null bs) || isJust g) $ + unless (not (null bs) || isLeft result) $ throwError $ mkErrorStack ("Duplicate value declaration '" ++ show ident ++ "'") Nothing caseDecl <- makeCaseDeclaration ident tuples return [caseDecl] @@ -103,18 +106,18 @@ isVarBinder (VarBinder _) = True isVarBinder _ = False -toTuple :: Declaration -> ([Binder], (Maybe Guard, Expr)) -toTuple (ValueDeclaration _ _ bs g val) = (bs, (g, val)) +toTuple :: Declaration -> ([Binder], Either [(Guard, Expr)] Expr) +toTuple (ValueDeclaration _ _ bs result) = (bs, result) toTuple (PositionedDeclaration _ d) = toTuple d toTuple _ = error "Not a value declaration" -makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Expr))] -> SupplyT (Either ErrorStack) Declaration +makeCaseDeclaration :: Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> SupplyT (Either ErrorStack) Declaration makeCaseDeclaration ident alternatives = do let argPattern = length . fst . head $ alternatives args <- map Ident <$> replicateM argPattern freshName let vars = map (Var . Qualified Nothing) args - binders = [ CaseAlternative bs g val | (bs, (g, val)) <- alternatives ] + binders = [ CaseAlternative bs result | (bs, result) <- alternatives ] value = foldr (Abs . Left) (Case vars binders) args - return $ ValueDeclaration ident Value [] Nothing value + return $ ValueDeclaration ident Value [] (Right value) diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -19,7 +19,7 @@ ) where import Language.PureScript.Names -import Language.PureScript.Declarations +import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Supply @@ -66,7 +66,7 @@ go (DoNotationBind binder val : rest) = do rest' <- go rest ident <- Ident <$> freshName - return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing rest'])) + return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')])) go [DoNotationLet _] = lift $ Left $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing go (DoNotationLet ds : rest) = do rest' <- go rest diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs --- 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 +-- Maintainer : Phil Freeman , Gary Burgess -- Stability : experimental -- Portability : -- @@ -16,6 +16,7 @@ desugarImports ) where +import Data.List (nub) import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Monoid ((<>)) @@ -24,7 +25,7 @@ import qualified Data.Map as M -import Language.PureScript.Declarations +import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Types import Language.PureScript.Environment @@ -158,7 +159,7 @@ let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports imports <- resolveImports env m - renameInModule imports env (elaborateExports exps m) + elaborateImports <$> renameInModule imports env (elaborateExports exps m) -- | -- Make all exports for a module explicit. This may still effect modules that have an exports list, @@ -171,6 +172,23 @@ map ValueRef (exportedValues exps)) -- | +-- Add `import X ()` for any modules where there are only fully qualified references to members. +-- This ensures transitive instances are included when using a member from a module. +-- +elaborateImports :: Module -> Module +elaborateImports (Module mn decls exps) = Module mn decls' exps + where + decls' :: [Declaration] + decls' = + let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues (const []) (const []) (const []) + in mkImport `map` nub (f `concatMap` decls) ++ decls + fqValues :: Expr -> [ModuleName] + fqValues (Var (Qualified (Just mn') _)) = [mn'] + fqValues _ = [] + mkImport :: ModuleName -> Declaration + mkImport mn' = ImportDeclaration mn' (Qualifying []) Nothing + +-- | -- Replaces all local names with qualified names within a module and checks that all existing -- qualified names are valid. -- @@ -222,10 +240,10 @@ updateBinder s v = return (s, v) updateCase :: (Maybe SourcePos, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourcePos, [Ident]), CaseAlternative) - updateCase (pos, bound) c@(CaseAlternative bs _ _) = return ((pos, concatMap binderNames bs ++ bound), c) + updateCase (pos, bound) c@(CaseAlternative bs _) = return ((pos, concatMap binderNames bs ++ bound), c) letBoundVariable :: Declaration -> Maybe Ident - letBoundVariable (ValueDeclaration ident _ _ _ _) = Just ident + letBoundVariable (ValueDeclaration ident _ _ _) = Just ident letBoundVariable (PositionedDeclaration _ d) = letBoundVariable d letBoundVariable _ = Nothing @@ -304,7 +322,7 @@ addDecl mn env (DataDeclaration _ tn _ dcs) = addType env mn tn (map fst dcs) addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn [] addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn [] - addDecl mn env (ValueDeclaration name _ _ _ _) = addValue env mn name + addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name addDecl mn env (PositionedDeclaration _ d) = addDecl mn env d addDecl _ env _ = return env diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -25,7 +25,7 @@ ) 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 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -18,7 +18,7 @@ desugarTypeClasses ) where -import Language.PureScript.Declarations +import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Types import Language.PureScript.Kinds @@ -211,7 +211,7 @@ typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) = - ValueDeclaration ident TypeClassAccessorImport [] Nothing $ + ValueDeclaration ident TypeClassAccessorImport [] $ Right $ TypedValue False (Abs (Left $ Ident "dict") (Accessor (runIdent ident) (Var $ Qualified Nothing (Ident "dict")))) $ moveQuantifiersToFront (quantify (ConstrainedType [(Qualified (Just mn) name, map (TypeVar . fst) args)] ty)) typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) = @@ -258,19 +258,19 @@ dictTy = foldl TypeApp (TypeConstructor className) tys constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy) dict = TypeClassDictionaryConstructorApp className memberNames' - result = ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy) + result = ValueDeclaration name TypeInstanceDictionaryValue [] (Right (TypedValue True dict constrainedTy)) return result where declName :: Declaration -> Maybe Ident declName (PositionedDeclaration _ d) = declName d - declName (ValueDeclaration ident _ _ _ _) = Just ident + declName (ValueDeclaration ident _ _ _) = Just ident declName (TypeDeclaration ident _) = Just ident declName _ = Nothing memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Expr) - memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do + memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _) = do _ <- lift . lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys' let memberValue = typeInstanceDictionaryEntryValue d return (ident, memberValue) @@ -280,7 +280,7 @@ memberToNameAndValue _ _ = error "Invalid declaration in type instance definition" typeInstanceDictionaryEntryValue :: Declaration -> Expr - typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] _ val) = val + typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] (Right val)) = val typeInstanceDictionaryEntryValue (PositionedDeclaration pos d) = PositionedValue pos (typeInstanceDictionaryEntryValue d) typeInstanceDictionaryEntryValue _ = error "Invalid declaration in type instance definition" diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -25,10 +25,11 @@ import Control.Monad.Error.Class import Control.Monad (forM) -import Language.PureScript.Declarations +import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Environment import Language.PureScript.Errors +import Language.PureScript.Traversals -- | -- Replace all top level type declarations in a module with type annotations @@ -47,18 +48,20 @@ return (PositionedDeclaration pos d' : ds') desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do (_, nameKind, val) <- fromValueDeclaration d - desugarTypeDeclarations (ValueDeclaration name nameKind [] Nothing (TypedValue True val ty) : rest) + desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest) where fromValueDeclaration :: Declaration -> Either ErrorStack (Ident, NameKind, Expr) - fromValueDeclaration (ValueDeclaration name' nameKind [] Nothing val) | name == name' = return (name', nameKind, val) + fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val) fromValueDeclaration (PositionedDeclaration pos d') = do (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d' return (ident, nameKind, PositionedValue pos val) fromValueDeclaration _ = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing -desugarTypeDeclarations (ValueDeclaration name nameKind bs g val : rest) = do +desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do let (_, f, _) = everywhereOnValuesTopDownM return go return - (:) <$> (ValueDeclaration name nameKind bs g <$> f val) <*> desugarTypeDeclarations rest + f' (Left gs) = Left <$> mapM (pairM return f) gs + f' (Right v) = Right <$> f v + (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations rest where go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val' go other = return other diff --git a/src/Language/PureScript/Traversals.hs b/src/Language/PureScript/Traversals.hs --- a/src/Language/PureScript/Traversals.hs +++ b/src/Language/PureScript/Traversals.hs @@ -25,9 +25,16 @@ thirdM :: (Functor f) => (c -> f d) -> (a, b, c) -> f (a, b, d) thirdM f (a, b, c) = (,,) a b <$> f c +pairM :: (Applicative f) => (a -> f c) -> (b -> f d) -> (a, b) -> f (c, d) +pairM f g (a, b) = (,) <$> f a <*> g b + maybeM :: (Applicative f) => (a -> f b) -> Maybe a -> f (Maybe b) maybeM _ Nothing = pure Nothing maybeM f (Just a) = Just <$> f a + +eitherM :: (Applicative f) => (a -> f c) -> (b -> f d) -> Either a b -> f (Either c d) +eitherM f _ (Left a) = Left <$> f a +eitherM _ g (Right b) = Right <$> g b defS :: (Monad m) => st -> val -> m (st, val) defS s val = return (s, val) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -37,7 +37,7 @@ import Language.PureScript.Types import Language.PureScript.Names import Language.PureScript.Kinds -import Language.PureScript.Declarations +import Language.PureScript.AST import Language.PureScript.TypeClassDictionaries import Language.PureScript.Environment import Language.PureScript.Errors @@ -145,7 +145,7 @@ (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls) forM_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do checkDuplicateTypeArguments $ map fst args - let args' = args `withKinds` ctorKind + let args' = args `withKinds` ctorKind addDataType moduleName dtype name args' dctors ctorKind forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do checkDuplicateTypeArguments $ map fst args @@ -169,12 +169,12 @@ ds <- go rest return $ TypeSynonymDeclaration name args ty : ds go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed" - go (ValueDeclaration name nameKind [] Nothing val : rest) = do + go (ValueDeclaration name nameKind [] (Right val) : rest) = do d <- rethrow (strMsg ("Error in declaration " ++ show name) <>) $ do valueIsNotDefined moduleName name [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)] addValue moduleName name ty nameKind - return $ ValueDeclaration name nameKind [] Nothing val' + return $ ValueDeclaration name nameKind [] $ Right val' ds <- go rest return $ d : ds go (ValueDeclaration{} : _) = error "Binders were not desugared" @@ -183,10 +183,10 @@ forM_ (map (\(ident, _, _) -> ident) vals) $ \name -> valueIsNotDefined moduleName name tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals - vals' <- forM [ (name, val, nameKind, ty) + vals' <- forM [ (name, val, nameKind, ty) | (name, nameKind, _) <- vals , (name', (val, ty)) <- tys - , name == name' + , name == name' ] $ \(name, val, nameKind, ty) -> do addValue moduleName name ty nameKind return (name, nameKind, val) @@ -248,9 +248,9 @@ rethrowWithPosition pos $ do (d' : rest') <- go (d : rest) return (PositionedDeclaration pos d' : rest') - + -- | - -- This function adds the argument kinds for a type constructor so that they may appear in the externs file, + -- This function adds the argument kinds for a type constructor so that they may appear in the externs file, -- extracted from the kind of the type constructor itself. -- withKinds :: [(String, Maybe Kind)] -> Kind -> [(String, Maybe Kind)] diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs new file mode 100644 --- /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 +-- 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 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -22,23 +22,23 @@ kindsOfAll ) where -import Language.PureScript.Types -import Language.PureScript.Kinds -import Language.PureScript.Names -import Language.PureScript.TypeChecker.Monad -import Language.PureScript.Pretty -import Language.PureScript.Environment -import Language.PureScript.Errors +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import qualified Data.HashMap.Strict as H +import qualified Data.Map as M -import Control.Monad.State +import Control.Applicative import Control.Monad.Error +import Control.Monad.State import Control.Monad.Unify -import Control.Applicative - -import qualified Data.Map as M -import qualified Data.HashMap.Strict as H -import Data.Monoid ((<>)) +import Language.PureScript.Environment +import Language.PureScript.Errors +import Language.PureScript.Kinds +import Language.PureScript.Names +import Language.PureScript.Pretty +import Language.PureScript.TypeChecker.Monad +import Language.PureScript.Types instance Partial Kind where unknown = KUnknown @@ -50,9 +50,7 @@ go _ = [] ($?) sub = everywhereOnKinds go where - go t@(KUnknown u) = case H.lookup u (runSubstitution sub) of - Nothing -> t - Just t' -> t' + go t@(KUnknown u) = fromMaybe t $ H.lookup u (runSubstitution sub) go other = other instance Unifiable Check Kind where @@ -85,12 +83,12 @@ tyCon <- fresh kargs <- replicateM (length args) fresh rest <- zipWithM freshKindVar args kargs - let dict = (name, tyCon) : rest + let dict = (name, tyCon) : rest bindLocalTypeVariables moduleName dict $ solveTypes isData ts kargs tyCon where tidyUp (k, sub) = starIfUnknown $ sub $? k - + freshKindVar :: (String, Maybe Kind) -> Kind -> UnifyT Kind Check (ProperName, Kind) freshKindVar (arg, Nothing) kind = return (ProperName arg, kind) freshKindVar (arg, Just kind') kind = do @@ -125,13 +123,13 @@ -- | -- Solve the set of kind constraints associated with the data constructors for a type constructor -- -solveTypes :: Bool -> [Type] -> [Kind] -> Kind -> UnifyT Kind (Check) Kind +solveTypes :: Bool -> [Type] -> [Kind] -> Kind -> UnifyT Kind Check Kind solveTypes isData ts kargs tyCon = do ks <- mapM infer ts when isData $ do tyCon =?= foldr FunKind Star kargs forM_ ks $ \k -> k =?= Star - when (not isData) $ do + unless isData $ tyCon =?= foldr FunKind (head ks) kargs return tyCon @@ -151,6 +149,7 @@ infer ty = rethrow (mkErrorStack "Error inferring type of value" (Just (TypeError ty)) <>) $ infer' ty infer' :: Type -> UnifyT Kind Check Kind +infer' TypeWildcard = fresh infer' (TypeVar v) = do Just moduleName <- checkCurrentModule <$> get UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v)) @@ -191,6 +190,3 @@ k =?= k' return k' infer' _ = error "Invalid argument to infer" - - - diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs --- 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 --- /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 +-- 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 --- /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 +-- 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 --- /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 +-- 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 --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -13,18 +13,29 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-} + module Language.PureScript.TypeChecker.Synonyms ( - saturateAllTypeSynonyms + saturateAllTypeSynonyms, + desaturateAllTypeSynonyms, + replaceAllTypeSynonyms, + expandAllTypeSynonyms, + expandTypeSynonym, + expandTypeSynonym' ) where -import Language.PureScript.Types -import Language.PureScript.Names - -import Control.Applicative ((<$>)) import Data.Maybe (fromMaybe) -import Control.Monad.Writer +import qualified Data.Map as M + +import Control.Applicative import Control.Monad.Error +import Control.Monad.State +import Language.PureScript.Environment +import Language.PureScript.Names +import Language.PureScript.TypeChecker.Monad +import Language.PureScript.Types + -- | -- Build a type substitution for a type synonym -- @@ -51,5 +62,49 @@ saturateAllTypeSynonyms :: [(Qualified ProperName, Int)] -> Type -> Either String Type saturateAllTypeSynonyms syns d = foldM (\result (name, n) -> saturateTypeSynonym name n result) d syns +-- | +-- \"Desaturate\" @SaturatedTypeSynonym@s +-- +desaturateAllTypeSynonyms :: Type -> Type +desaturateAllTypeSynonyms = everywhereOnTypes replaceSaturatedTypeSynonym + where + replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args + replaceSaturatedTypeSynonym t = t +-- | +-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate +-- better error messages during unification. +-- +replaceAllTypeSynonyms' :: Environment -> Type -> Either String Type +replaceAllTypeSynonyms' env d = + let + syns = map (\(name, (args, _)) -> (name, length args)) . M.toList $ typeSynonyms env + in + saturateAllTypeSynonyms syns d +replaceAllTypeSynonyms :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type +replaceAllTypeSynonyms d = do + env <- getEnv + either (throwError . strMsg) return $ replaceAllTypeSynonyms' env d + +-- | +-- Replace a type synonym and its arguments with the aliased type +-- +expandTypeSynonym' :: Environment -> Qualified ProperName -> [Type] -> Either String Type +expandTypeSynonym' env name args = + case M.lookup name (typeSynonyms env) of + Just (synArgs, body) -> do + let repl = replaceAllTypeVars (zip (map fst synArgs) args) body + replaceAllTypeSynonyms' env repl + Nothing -> error "Type synonym was not defined" + +expandTypeSynonym :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type +expandTypeSynonym name args = do + env <- getEnv + either (throwError . strMsg) return $ expandTypeSynonym' env name args + +expandAllTypeSynonyms :: (Error e, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type +expandAllTypeSynonyms = everywhereOnTypesTopDownM go + where + go (SaturatedTypeSynonym name args) = expandTypeSynonym name args + go other = return other diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs --- 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,138 +33,38 @@ checkFunctionApplication Check a function of a given type returns a value of another type when applied to its arguments - - subsumes - Check a type subsumes another type -} +import Data.Either (lefts, rights) import Data.List -import Data.Maybe (maybeToList, fromMaybe) -import Data.Function (on) -import Data.Ord (comparing) +import Data.Maybe (fromMaybe) import Data.Monoid -import Data.Either (lefts, rights) +import qualified Data.Map as M -import Language.PureScript.Declarations -import Language.PureScript.Types +import Control.Applicative +import Control.Monad.Error +import Control.Monad.State +import Control.Monad.Unify + +import Language.PureScript.AST +import Language.PureScript.Environment +import Language.PureScript.Errors import Language.PureScript.Kinds import Language.PureScript.Names -import Language.PureScript.TypeClassDictionaries -import Language.PureScript.TypeChecker.Monad +import Language.PureScript.Pretty +import Language.PureScript.TypeChecker.Entailment import Language.PureScript.TypeChecker.Kinds +import Language.PureScript.TypeChecker.Monad +import Language.PureScript.TypeChecker.Rows +import Language.PureScript.TypeChecker.Skolems +import Language.PureScript.TypeChecker.Subsumption import Language.PureScript.TypeChecker.Synonyms -import Language.PureScript.Pretty -import Language.PureScript.Environment -import Language.PureScript.Errors +import Language.PureScript.TypeChecker.Unify +import Language.PureScript.TypeClassDictionaries +import Language.PureScript.Types import qualified Language.PureScript.Constants as C -import Control.Monad.State -import Control.Monad.Error -import Control.Monad.Unify - -import Control.Applicative -import Control.Arrow (Arrow(..)) - -import qualified Data.Map as M -import qualified Data.HashMap.Strict as H - -instance Partial Type where - unknown = TUnknown - isUnknown (TUnknown u) = Just u - isUnknown _ = Nothing - unknowns = everythingOnTypes (++) go - where - go (TUnknown u) = [u] - go _ = [] - ($?) sub = everywhereOnTypes go - where - go t@(TUnknown u) = case H.lookup u (runSubstitution sub) of - Nothing -> t - Just t' -> t' - go other = other - -instance Unifiable Check Type where - (=?=) = unifyTypes - -- | --- Unify two types, updating the current substitution --- -unifyTypes :: Type -> Type -> UnifyT Type Check () -unifyTypes t1 t2 = rethrow (mkErrorStack ("Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2) Nothing <>) $ - unifyTypes' t1 t2 - where - unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return () - unifyTypes' (TUnknown u) t = u =:= t - unifyTypes' t (TUnknown u) = u =:= t - unifyTypes' (SaturatedTypeSynonym name args) ty = do - ty1 <- introduceSkolemScope <=< expandTypeSynonym name $ args - ty1 `unifyTypes` ty - unifyTypes' ty s@(SaturatedTypeSynonym _ _) = s `unifyTypes` ty - unifyTypes' (ForAll ident1 ty1 sc1) (ForAll ident2 ty2 sc2) = - case (sc1, sc2) of - (Just sc1', Just sc2') -> do - sko <- newSkolemConstant - let sk1 = skolemize ident1 sko sc1' ty1 - let sk2 = skolemize ident2 sko sc2' ty2 - sk1 `unifyTypes` sk2 - _ -> error "Skolemized type variable was not given a scope" - unifyTypes' (ForAll ident ty1 (Just sc)) ty2 = do - sko <- newSkolemConstant - let sk = skolemize ident sko sc ty1 - sk `unifyTypes` ty2 - unifyTypes' ForAll{} _ = throwError . strMsg $ "Skolem variable scope is unspecified" - unifyTypes' ty f@ForAll{} = f `unifyTypes` ty - unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return () - unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = - guardWith (strMsg ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".")) (c1 == c2) - unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do - t3 `unifyTypes` t5 - t4 `unifyTypes` t6 - unifyTypes' (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = return () - unifyTypes' (KindedType ty1 _) ty2 = ty1 `unifyTypes` ty2 - unifyTypes' ty1 (KindedType ty2 _) = ty1 `unifyTypes` ty2 - unifyTypes' r1@RCons{} r2 = unifyRows r1 r2 - unifyTypes' r1 r2@RCons{} = unifyRows r1 r2 - unifyTypes' r1@REmpty r2 = unifyRows r1 r2 - unifyTypes' r1 r2@REmpty = unifyRows r1 r2 - unifyTypes' t@(ConstrainedType _ _) _ = throwError . strMsg $ "Attempted to unify a constrained type " ++ prettyPrintType t ++ " with another type." - unifyTypes' t3 t4@(ConstrainedType _ _) = unifyTypes' t4 t3 - unifyTypes' t3 t4 = throwError . strMsg $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "." - --- | --- Unify two rows, updating the current substitution --- --- Common labels are first identified, and unified. Remaining labels and types are unified with a --- trailing row unification variable, if appropriate, otherwise leftover labels result in a unification --- error. --- -unifyRows :: Type -> Type -> UnifyT Type Check () -unifyRows r1 r2 = - let - (s1, r1') = rowToList r1 - (s2, r2') = rowToList r2 - int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ] - sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ] - sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ] - in do - forM_ int (uncurry (=?=)) - unifyRows' sd1 r1' sd2 r2' - where - unifyRows' :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> UnifyT Type Check () - unifyRows' [] (TUnknown u) sd r = u =:= rowFromList (sd, r) - unifyRows' sd r [] (TUnknown u) = u =:= rowFromList (sd, r) - unifyRows' sd1 (TUnknown u1) sd2 (TUnknown u2) = do - forM_ sd1 $ \(_, t) -> occursCheck u2 t - forM_ sd2 $ \(_, t) -> occursCheck u1 t - rest <- fresh - u1 =:= rowFromList (sd2, rest) - u2 =:= rowFromList (sd1, rest) - unifyRows' [] REmpty [] REmpty = return () - unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return () - unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return () - unifyRows' sd3 r3 sd4 r4 = throwError . strMsg $ "Cannot unify (" ++ prettyPrintRow (rowFromList (sd3, r3)) ++ ") with (" ++ prettyPrintRow (rowFromList (sd4, r4)) ++ ")" - --- | -- Infer the types of multiple mutually-recursive values, and return elaborated values including -- type class dictionaries and type annotations. -- @@ -232,15 +129,17 @@ checkTypedBindingGroupElement :: ModuleName -> (Ident, (Expr, Type, Bool)) -> TypeData -> UnifyT Type Check (Ident, (Expr, Type)) checkTypedBindingGroupElement moduleName (ident, (val', ty, checkType)) dict = do + -- Replace type wildcards + ty' <- replaceTypeWildcards ty -- Kind check kind <- liftCheck $ kindOf moduleName ty guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star -- Check the type with the new names in scope - ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty + ty'' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty' val'' <- if checkType - then bindNames dict $ TypedValue True <$> check val' ty' <*> pure ty' - else return (TypedValue False val' ty') - return (ident, (val'', ty')) + then bindNames dict $ TypedValue True <$> check val' ty'' <*> pure ty'' + else return (TypedValue False val' ty'') + return (ident, (val'', ty'')) typeForBindingGroupElement :: (Ident, Expr) -> TypeData -> UntypedData -> UnifyT Type Check (Ident, (Expr, Type)) typeForBindingGroupElement (ident, val) dict untypedDict = do @@ -252,7 +151,7 @@ -- | -- Check if a value contains a type annotation -- -isTyped :: (Ident, Expr) -> (Either (Ident, Expr) (Ident, (Expr, Type, Bool))) +isTyped :: (Ident, Expr) -> Either (Ident, Expr) (Ident, (Expr, Type, Bool)) isTyped (name, TypedValue checkType value ty) = Right (name, (value, ty, checkType)) isTyped (name, value) = Left (name, value) @@ -281,291 +180,12 @@ go other = return other -- | --- A simplified representation of expressions which are used to represent type --- class dictionaries at runtime, which can be compared for equality --- -data DictionaryValue - -- | - -- A dictionary which is brought into scope by a local constraint - -- - = LocalDictionaryValue (Qualified Ident) - -- | - -- A dictionary which is brought into scope by an instance declaration - -- - | GlobalDictionaryValue (Qualified Ident) - -- | - -- A dictionary which depends on other dictionaries - -- - | DependentDictionaryValue (Qualified Ident) [DictionaryValue] - -- | - -- A subclass dictionary - -- - | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer - deriving (Show, Ord, Eq) - --- | --- Check that the current set of type class dictionaries entail the specified type class goal, and, if so, --- return a type class dictionary reference. --- -entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Bool -> Check Expr -entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filter filterModule context)) - where - sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v] - sortedNubBy f vs = M.elems (M.fromList (map (f &&& id) vs)) - - -- Filter out type dictionaries which are in scope in the current module - filterModule :: TypeClassDictionaryInScope -> Bool - filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True - filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True - filterModule _ = False - - solve context' (className, tys) trySuperclasses = - checkOverlaps $ go trySuperclasses className tys - where - go trySuperclasses' className' tys' = - -- Look for regular type instances - [ mkDictionary (canonicalizeDictionary tcd) args - | tcd <- context' - -- Make sure the type class name matches the one we are trying to satisfy - , className' == tcdClassName tcd - -- Make sure the type unifies with the type in the type instance definition - , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd) - -- Solve any necessary subgoals - , args <- solveSubgoals subst (tcdDependencies tcd) ] ++ - - -- Look for implementations via superclasses - [ SubclassDictionaryValue suDict superclass index - | trySuperclasses' - , (subclassName, (args, _, implies)) <- M.toList (typeClasses env) - -- Try each superclass - , (index, (superclass, suTyArgs)) <- zip [0..] implies - -- Make sure the type class name matches the superclass name - , className' == superclass - -- Make sure the types unify with the types in the superclass implication - , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs - -- Finally, satisfy the subclass constraint - , args' <- maybeToList $ mapM (flip lookup subst) (map fst args) - , suDict <- go True subclassName args' ] - - -- Create dictionaries for subgoals which still need to be solved by calling go recursively - -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type - -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively. - solveSubgoals :: [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [DictionaryValue]] - solveSubgoals _ Nothing = return Nothing - solveSubgoals subst (Just subgoals) = do - dict <- mapM (uncurry (go True) . second (map (replaceAllTypeVars subst))) subgoals - return $ Just dict - -- Make a dictionary from subgoal dictionaries by applying the correct function - mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue - mkDictionary fnName Nothing = LocalDictionaryValue fnName - mkDictionary fnName (Just []) = GlobalDictionaryValue fnName - mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts - -- Turn a DictionaryValue into a Expr - dictionaryValueToValue :: DictionaryValue -> Expr - dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName - dictionaryValueToValue (GlobalDictionaryValue fnName) = Var fnName - dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts) - dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) = - App (Accessor (C.__superclass_ ++ show superclassName ++ "_" ++ show index) - (dictionaryValueToValue dict)) - valUndefined - -- Ensure that a substitution is valid - verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)] - verifySubstitution subst = do - let grps = groupBy ((==) `on` fst) subst - guard (all (pairwise (unifiesWith env) . map snd) grps) - return $ map head grps - -- | - -- Check for overlapping instances - -- - checkOverlaps :: [DictionaryValue] -> Check Expr - checkOverlaps dicts = - case [ (d1, d2) | d1 <- dicts, d2 <- dicts, d1 `overlapping` d2 ] of - (d1, d2) : _ -> throwError . strMsg $ unlines - [ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintType tys) ++ "." - , "For example:" - , prettyPrintDictionaryValue d1 - , "and:" - , prettyPrintDictionaryValue d2 - ] - _ -> case chooseSimplestDictionaries dicts of - [] -> throwError . strMsg $ - "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys) - d : _ -> return $ dictionaryValueToValue d - -- Choose the simplest DictionaryValues from a list of candidates - -- The reason for this function is as follows: - -- When considering overlapping instances, we don't want to consider the same dictionary - -- to be an overlap of itself when obtained as a superclass of another class. - -- Observing that we probably don't want to select a superclass instance when an instance - -- is available directly, and that there is no way for a superclass instance to actually - -- introduce an overlap that wouldn't have been there already, we simply remove dictionaries - -- obtained as superclass instances if there are simpler instances available. - chooseSimplestDictionaries :: [DictionaryValue] -> [DictionaryValue] - chooseSimplestDictionaries ds = case filter isSimpleDictionaryValue ds of - [] -> ds - simple -> simple - isSimpleDictionaryValue SubclassDictionaryValue{} = False - isSimpleDictionaryValue (DependentDictionaryValue _ ds) = all isSimpleDictionaryValue ds - isSimpleDictionaryValue _ = True - -- | - -- Check if two dictionaries are overlapping - -- - -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have - -- been caught when constructing superclass dictionaries. - -- - overlapping :: DictionaryValue -> DictionaryValue -> Bool - overlapping (LocalDictionaryValue nm1) (LocalDictionaryValue nm2) | nm1 == nm2 = False - overlapping (GlobalDictionaryValue nm1) (GlobalDictionaryValue nm2) | nm1 == nm2 = False - overlapping (DependentDictionaryValue nm1 ds1) (DependentDictionaryValue nm2 ds2) - | nm1 == nm2 = any id $ zipWith overlapping ds1 ds2 - overlapping (SubclassDictionaryValue _ _ _) _ = False - overlapping _ (SubclassDictionaryValue _ _ _) = False - overlapping _ _ = True - -- | - -- Render a DictionaryValue fit for human consumption in error messages - -- - prettyPrintDictionaryValue :: DictionaryValue -> String - prettyPrintDictionaryValue = unlines . indented 0 - where - indented n (LocalDictionaryValue _) = [spaces n ++ "Dictionary in scope"] - indented n (GlobalDictionaryValue nm) = [spaces n ++ show nm] - indented n (DependentDictionaryValue nm args) = (spaces n ++ show nm ++ " via") : concatMap (indented (n + 2)) args - indented n (SubclassDictionaryValue sup nm _) = (spaces n ++ show nm ++ " via superclass") : indented (n + 2) sup - - spaces n = replicate n ' ' ++ "- " - - valUndefined :: Expr - valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined)) - --- | --- Check all values in a list pairwise match a predicate --- -pairwise :: (a -> a -> Bool) -> [a] -> Bool -pairwise _ [] = True -pairwise _ [_] = True -pairwise p (x : xs) = all (p x) xs && pairwise p xs - --- | --- Check that two types unify --- -unifiesWith :: Environment -> Type -> Type -> Bool -unifiesWith _ (TUnknown u1) (TUnknown u2) | u1 == u2 = True -unifiesWith _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = True -unifiesWith _ (TypeVar v1) (TypeVar v2) | v1 == v2 = True -unifiesWith _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True -unifiesWith e (TypeApp h1 t1) (TypeApp h2 t2) = unifiesWith e h1 h2 && unifiesWith e t1 t2 -unifiesWith e (SaturatedTypeSynonym name args) t2 = - case expandTypeSynonym' e name args of - Left _ -> False - Right t1 -> unifiesWith e t1 t2 -unifiesWith e t1 t2@(SaturatedTypeSynonym _ _) = unifiesWith e t2 t1 -unifiesWith _ _ _ = False - --- | --- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup), --- and return a substitution from type variables to types which makes the type heads unify. --- -typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)] -typeHeadsAreEqual _ _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = Just [] -typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)] -typeHeadsAreEqual _ _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just [] -typeHeadsAreEqual m e (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m e h1 h2 <*> typeHeadsAreEqual m e t1 t2 -typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e name args of - Left _ -> Nothing - Right t1 -> typeHeadsAreEqual m e t1 t2 -typeHeadsAreEqual _ _ _ _ = Nothing - --- | --- Ensure skolem variables do not escape their scope --- -skolemEscapeCheck :: Expr -> Check () -skolemEscapeCheck (TypedValue False _ _) = return () -skolemEscapeCheck root@TypedValue{} = - -- Every skolem variable is created when a ForAll type is skolemized. - -- This determines the scope of that skolem variable, which is copied from the SkolemScope - -- field of the ForAll constructor. - -- We traverse the tree top-down, and collect any SkolemScopes introduced by ForAlls. - -- If a Skolem is encountered whose SkolemScope is not in the current list, we have found - -- an escaped skolem variable. - let (_, f, _, _, _) = everythingWithContextOnValues [] [] (++) def go def def def - in case f root of - [] -> return () - ((binding, val) : _) -> throwError $ mkErrorStack ("Rigid/skolem type variable " ++ maybe "" (("bound by " ++) . prettyPrintValue) binding ++ " has escaped.") (Just (ExprError val)) - where - def s _ = (s, []) - - go :: [(SkolemScope, Expr)] -> Expr -> ([(SkolemScope, Expr)], [(Maybe Expr, Expr)]) - go scos val@(TypedValue _ _ (ForAll _ _ (Just sco))) = ((sco, val) : scos, []) - go scos val@(TypedValue _ _ ty) = case collectSkolems ty \\ map fst scos of - (sco : _) -> (scos, [(findBindingScope sco, val)]) - _ -> (scos, []) - where - collectSkolems :: Type -> [SkolemScope] - collectSkolems = nub . everythingOnTypes (++) collect - where - collect (Skolem _ _ scope) = [scope] - collect _ = [] - go scos _ = (scos, []) - findBindingScope :: SkolemScope -> Maybe Expr - findBindingScope sco = - let (_, f, _, _, _) = everythingOnValues mappend (const mempty) go' (const mempty) (const mempty) (const mempty) - in getFirst $ f root - where - go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = First (Just val) - go' _ = mempty -skolemEscapeCheck val = throwError $ mkErrorStack "Untyped value passed to skolemEscapeCheck" (Just (ExprError val)) - --- | --- Ensure rows do not contain duplicate labels --- -checkDuplicateLabels :: Expr -> Check () -checkDuplicateLabels = - let (_, f, _) = everywhereOnValuesM def go def - in void . f - where - def :: a -> Check a - def = return - - go :: Expr -> Check Expr - go e@(TypedValue _ val ty) = do - checkDups ty - return e - - where - checkDups :: Type -> Check () - checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2 - checkDups (SaturatedTypeSynonym _ ts) = mapM_ checkDups ts - checkDups (ForAll _ t _) = checkDups t - checkDups (ConstrainedType args t) = do - mapM_ (checkDups) $ concatMap snd args - checkDups t - checkDups r@(RCons _ _ _) = - let (ls, _) = rowToList r in - case firstDup . sort . map fst $ ls of - Just l -> throwError $ mkErrorStack ("Duplicate label " ++ show l ++ " in row") $ Just (ExprError val) - Nothing -> return () - checkDups _ = return () - - firstDup :: (Eq a) => [a] -> Maybe a - firstDup (x : xs@(x' : _)) - | x == x' = Just x - | otherwise = firstDup xs - firstDup _ = Nothing - - go other = return other - --- | --- Replace outermost unsolved unification variables with named type variables +-- Check the kind of a type, failing if it is not of kind *. -- -varIfUnknown :: Type -> Type -varIfUnknown ty = - let unks = nub $ unknowns ty - toName = (:) 't' . show - ty' = everywhereOnTypes typeToVar ty - typeToVar :: Type -> Type - typeToVar (TUnknown u) = TypeVar (toName u) - typeToVar t = t - in mkForAll (sort . map toName $ unks) ty' +checkTypeKind :: ModuleName -> Type -> UnifyT t Check () +checkTypeKind moduleName ty = do + kind <- liftCheck $ kindOf moduleName ty + guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star -- | -- Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns @@ -585,67 +205,6 @@ instantiatePolyTypeWithUnknowns val ty = return (val, ty) -- | --- Replace a single type variable with a new unification variable --- -replaceVarWithUnknown :: String -> Type -> UnifyT Type Check Type -replaceVarWithUnknown ident ty = do - tu <- fresh - return $ replaceTypeVars ident tu ty - --- | --- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate --- better error messages during unification. --- -replaceAllTypeSynonyms' :: Environment -> Type -> Either String Type -replaceAllTypeSynonyms' env d = - let - syns = map (\(name, (args, _)) -> (name, length args)) . M.toList $ typeSynonyms env - in - saturateAllTypeSynonyms syns d - -replaceAllTypeSynonyms :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type -replaceAllTypeSynonyms d = do - env <- getEnv - either (throwError . strMsg) return $ replaceAllTypeSynonyms' env d - --- | --- \"Desaturate\" @SaturatedTypeSynonym@s --- -desaturateAllTypeSynonyms :: Type -> Type -desaturateAllTypeSynonyms = everywhereOnTypes replaceSaturatedTypeSynonym - where - replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args - replaceSaturatedTypeSynonym t = t - --- | --- Replace a type synonym and its arguments with the aliased type --- -expandTypeSynonym' :: Environment -> Qualified ProperName -> [Type] -> Either String Type -expandTypeSynonym' env name args = - case M.lookup name (typeSynonyms env) of - Just (synArgs, body) -> do - let repl = replaceAllTypeVars (zip (map fst synArgs) args) body - replaceAllTypeSynonyms' env repl - Nothing -> error "Type synonym was not defined" - -expandTypeSynonym :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type -expandTypeSynonym name args = do - env <- getEnv - either (throwError . strMsg) return $ expandTypeSynonym' env name args - -expandAllTypeSynonyms :: (Error e, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type -expandAllTypeSynonyms = everywhereOnTypesTopDownM go - where - go (SaturatedTypeSynonym name args) = expandTypeSynonym name args - go other = return other - --- | --- Ensure a set of property names and value does not contain duplicate labels --- -ensureNoDuplicateProperties :: (Error e, MonadError e m) => [(String, Expr)] -> m () -ensureNoDuplicateProperties ps = guardWith (strMsg "Duplicate property names") $ length (nub . map fst $ ps) == length ps - --- | -- Infer a type for a value, rethrowing any error to provide a more useful error message -- infer :: Expr -> UnifyT Type Check Expr @@ -702,7 +261,7 @@ infer' (Var var) = do Just moduleName <- checkCurrentModule <$> get checkVisibility moduleName var - ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var + ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards <=< lookupVariable moduleName $ var case ty of ConstrainedType constraints ty' -> do dicts <- getTypeClassDictionaries @@ -733,9 +292,8 @@ return $ TypeClassDictionary False (className, tys) dicts infer' (TypedValue checkType val ty) = do Just moduleName <- checkCurrentModule <$> get - kind <- liftCheck $ kindOf moduleName ty - guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star - ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty + checkTypeKind moduleName ty + ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty val' <- if checkType then check val ty' else return val return $ TypedValue True val' ty' infer' (PositionedValue pos val) = rethrowWithPosition pos $ infer' val @@ -743,21 +301,20 @@ inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Type Check Expr) -> UnifyT Type Check ([Declaration], Expr) inferLetBinding seen [] ret j = (,) seen <$> makeBindingGroupVisible (j ret) -inferLetBinding seen (ValueDeclaration ident nameKind [] Nothing tv@(TypedValue checkType val ty) : rest) ret j = do +inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue checkType val ty))) : rest) ret j = do Just moduleName <- checkCurrentModule <$> get - kind <- liftCheck $ kindOf moduleName ty - guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star + checkTypeKind moduleName ty let dict = M.singleton (moduleName, ident) (ty, nameKind, Undefined) - ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty + ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty TypedValue _ val' ty'' <- if checkType then bindNames dict (check val ty') else return tv - bindNames (M.singleton (moduleName, ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing (TypedValue checkType val' ty'')]) rest ret j -inferLetBinding seen (ValueDeclaration ident nameKind [] Nothing val : rest) ret j = do + bindNames (M.singleton (moduleName, ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right (TypedValue checkType val' ty''))]) rest ret j +inferLetBinding seen (ValueDeclaration ident nameKind [] (Right val) : rest) ret j = do valTy <- fresh Just moduleName <- checkCurrentModule <$> get let dict = M.singleton (moduleName, ident) (valTy, nameKind, Undefined) TypedValue _ val' valTy' <- bindNames dict $ infer val valTy =?= valTy' - bindNames (M.singleton (moduleName, ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing val']) rest ret j + bindNames (M.singleton (moduleName, ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right val')]) rest ret j inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do Just moduleName <- checkCurrentModule <$> get (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds) @@ -766,7 +323,7 @@ let ds' = [(ident, LocalVariable, val') | (ident, (val', _)) <- ds1' ++ ds2'] makeBindingGroupVisible $ bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j inferLetBinding seen (PositionedDeclaration pos d : ds) ret j = rethrowWithPosition pos $ do - ((d' : ds'), val') <- inferLetBinding seen (d : ds) ret j + (d' : ds', val') <- inferLetBinding seen (d : ds) ret j return (PositionedDeclaration pos d' : ds', val') inferLetBinding _ _ _ _ = error "Invalid argument to inferLetBinding" @@ -845,60 +402,27 @@ -- checkBinders :: [Type] -> Type -> [CaseAlternative] -> UnifyT Type Check [CaseAlternative] checkBinders _ _ [] = return [] -checkBinders nvals ret (CaseAlternative binders grd val : bs) = do +checkBinders nvals ret (CaseAlternative binders result : bs) = do guardWith (strMsg "Overlapping binders in case statement") $ let ns = concatMap binderNames binders in length (nub ns) == length ns Just moduleName <- checkCurrentModule <$> get m1 <- M.unions <$> zipWithM inferBinder nvals binders - r <- bindLocalVariables moduleName [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $ do - val' <- TypedValue True <$> check val ret <*> pure ret - case grd of - Nothing -> return $ CaseAlternative binders Nothing val' - Just g -> do - g' <- check g tyBoolean - return $ CaseAlternative binders (Just g') val' + r <- bindLocalVariables moduleName [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $ + CaseAlternative binders <$> + case result of + Left gs -> do + gs' <- forM gs $ \(grd, val) -> do + grd' <- check grd tyBoolean + val' <- TypedValue True <$> check val ret <*> pure ret + return (grd', val') + return $ Left gs' + Right val -> do + val' <- TypedValue True <$> check val ret <*> pure ret + return $ Right val' rs <- checkBinders nvals ret bs return $ r : rs -- | --- Generate a new skolem constant --- -newSkolemConstant :: UnifyT Type Check Int -newSkolemConstant = fresh' - --- | --- Generate a new skolem scope --- -newSkolemScope :: UnifyT Type Check SkolemScope -newSkolemScope = SkolemScope <$> fresh' - --- | --- Skolemize a type variable by replacing its instances with fresh skolem constants --- -skolemize :: String -> Int -> SkolemScope -> Type -> Type -skolemize ident sko scope = replaceTypeVars ident (Skolem ident sko scope) - --- | --- This function has one purpose - to skolemize type variables appearing in a --- SuperClassDictionary placeholder. These type variables are somewhat unique since they are the --- only example of scoped type variables. --- -skolemizeTypesInValue :: String -> Int -> SkolemScope -> Expr -> Expr -skolemizeTypesInValue ident sko scope = let (_, f, _) = everywhereOnValues id go id in f - where - go (SuperClassDictionary c ts) = SuperClassDictionary c (map (skolemize ident sko scope) ts) - go other = other - --- | --- Introduce skolem scope at every occurence of a ForAll --- -introduceSkolemScope :: Type -> UnifyT Type Check Type -introduceSkolemScope = everywhereOnTypesM go - where - go (ForAll ident ty Nothing) = ForAll ident ty <$> (Just <$> newSkolemScope) - go other = return other - --- | -- Check the type of a value, rethrowing errors to provide a better error message -- check :: Expr -> Type -> UnifyT Type Check Expr @@ -961,7 +485,7 @@ Just moduleName <- checkCurrentModule <$> get checkVisibility moduleName var repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var - ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty + ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty v' <- subsumes (Just v) repl ty' case v' of Nothing -> throwError . strMsg $ "Unable to check type subsumption" @@ -981,10 +505,9 @@ return $ TypeClassDictionary False (className, tys) dicts check' (TypedValue checkType val ty1) ty2 = do Just moduleName <- checkCurrentModule <$> get - kind <- liftCheck $ kindOf moduleName ty1 - guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star - ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1 - ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty2 + checkTypeKind moduleName ty1 + ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty1 + ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2 val' <- subsumes (Just val) ty1' ty2' case val' of Nothing -> throwError . strMsg $ "Unable to check type subsumption" @@ -1031,10 +554,10 @@ _ <- subsumes Nothing repl ty return $ TypedValue True (Constructor c) ty check' (Let ds val) ty = do - (ds', val') <- inferLetBinding [] ds val (flip check ty) + (ds', val') <- inferLetBinding [] ds val (`check` ty) return $ TypedValue True (Let ds' val') ty check' val ty | containsTypeSynonyms ty = do - ty' <- introduceSkolemScope <=< expandAllTypeSynonyms $ ty + ty' <- introduceSkolemScope <=< expandAllTypeSynonyms <=< replaceTypeWildcards $ ty check val ty' check' val kt@(KindedType ty kind) = do guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star @@ -1059,7 +582,7 @@ go [] [] REmpty = return [] go [] [] u@(TUnknown _) = do u =?= REmpty return [] - go [] [] (Skolem _ _ _) | lax = return [] + go [] [] Skolem{} | lax = return [] go [] ((p, _): _) _ | lax = return [] | otherwise = throwError $ mkErrorStack ("Object does not have property " ++ p) (Just (ExprError (ObjectLiteral ps))) go ((p,_):_) [] REmpty = throwError $ mkErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ExprError (ObjectLiteral ps))) @@ -1122,85 +645,18 @@ checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg ret = do ty <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs checkFunctionApplication fn ty arg ret -checkFunctionApplication' fn (KindedType ty _) arg ret = do +checkFunctionApplication' fn (KindedType ty _) arg ret = checkFunctionApplication fn ty arg ret checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do dicts <- getTypeClassDictionaries checkFunctionApplication' (foldl App fn (map (flip (TypeClassDictionary True) dicts) constraints)) fnTy arg ret -checkFunctionApplication' fn fnTy dict@(TypeClassDictionary _ _ _) _ = +checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} _ = return (fnTy, App fn dict) checkFunctionApplication' _ fnTy arg _ = throwError . strMsg $ "Cannot apply a function of type " ++ prettyPrintType fnTy ++ " to argument " ++ prettyPrintValue arg -- | --- Check whether one type subsumes another, rethrowing errors to provide a better error message --- -subsumes :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr) -subsumes val ty1 ty2 = rethrow (mkErrorStack errorMessage (ExprError <$> val) <>) $ subsumes' val ty1 ty2 - where - errorMessage = "Error checking that type " - ++ prettyPrintType ty1 - ++ " subsumes type " - ++ prettyPrintType ty2 - --- | --- Check whether one type subsumes another --- -subsumes' :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr) -subsumes' val (ForAll ident ty1 _) ty2 = do - replaced <- replaceVarWithUnknown ident ty1 - subsumes val replaced ty2 -subsumes' val ty1 (ForAll ident ty2 sco) = - case sco of - Just sco' -> do - sko <- newSkolemConstant - let sk = skolemize ident sko sco' ty2 - subsumes val ty1 sk - Nothing -> throwError . strMsg $ "Skolem variable scope is unspecified" -subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do - _ <- subsumes Nothing arg2 arg1 - _ <- subsumes Nothing ret1 ret2 - return val -subsumes' val (SaturatedTypeSynonym name tyArgs) ty2 = do - ty1 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs - subsumes val ty1 ty2 -subsumes' val ty1 (SaturatedTypeSynonym name tyArgs) = do - ty2 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs - subsumes val ty1 ty2 -subsumes' val (KindedType ty1 _) ty2 = do - subsumes val ty1 ty2 -subsumes' val ty1 (KindedType ty2 _) = do - subsumes val ty1 ty2 -subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do - dicts <- getTypeClassDictionaries - subsumes' (Just $ foldl App val (map (flip (TypeClassDictionary True) dicts) constraints)) ty1 ty2 -subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyObject && f2 == tyObject = do - let - (ts1, r1') = rowToList r1 - (ts2, r2') = rowToList r2 - ts1' = sortBy (comparing fst) ts1 - ts2' = sortBy (comparing fst) ts2 - go ts1' ts2' r1' r2' - return val - where - go [] ts2 r1' r2' = r1' =?= rowFromList (ts2, r2') - go ts1 [] r1' r2' = r2' =?= rowFromList (ts1, r1') - go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1' r2' - | p1 == p2 = do _ <- subsumes Nothing ty1 ty2 - go ts1 ts2 r1' r2' - | p1 < p2 = do rest <- fresh - r2' =?= RCons p1 ty1 rest - go ts1 ((p2, ty2) : ts2) r1' rest - | otherwise = do rest <- fresh - r1' =?= RCons p2 ty2 rest - go ((p1, ty1) : ts1) ts2 rest r2' -subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyObject = subsumes val ty2 ty1 -subsumes' val ty1 ty2 = do - ty1 =?= ty2 - return val - --- | -- Compute the meet of two types, i.e. the most general type which both types subsume. -- TODO: handle constrained types -- @@ -1215,9 +671,8 @@ t1 =?= t2 return (e1, e2, t1) - - - - - - +-- | +-- Ensure a set of property names and value does not contain duplicate labels +-- +ensureNoDuplicateProperties :: (Error e, MonadError e m) => [(String, Expr)] -> m () +ensureNoDuplicateProperties ps = guardWith (strMsg "Duplicate property names") $ length (nub . map fst $ ps) == length ps diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs new file mode 100644 --- /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 +-- 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 --- a/src/Language/PureScript/TypeClassDictionaries.hs +++ b/src/Language/PureScript/TypeClassDictionaries.hs @@ -64,3 +64,10 @@ -- A type class dictionary which is an alias for an imported dictionary from another module -- | TCDAlias (Qualified Ident) deriving (Show, Eq, Data, Typeable) + +-- | +-- Find the original dictionary which a type class dictionary in scope refers to +-- +canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident +canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm +canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -47,6 +47,10 @@ -- | TypeVar String -- | + -- A type wildcard, as would appear in a partial type synonym + -- + | TypeWildcard + -- | -- A type constructor -- | TypeConstructor (Qualified ProperName) @@ -214,6 +218,16 @@ in case qs of [] -> constrained qs' -> foldl (\ty' (q, sco) -> ForAll q ty' sco) constrained qs' + +-- | +-- Check if a type contains wildcards +-- +containsWildcards :: Type -> Bool +containsWildcards = everythingOnTypes (||) go + where + go :: Type -> Bool + go TypeWildcard = True + go _ = False -- -- Traversals