summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-02-10 05:28:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-02-10 05:28:00 (GMT)
commitb6cbc00be397476d10881590bd1201666d5bee69 (patch)
tree48660e2ed6a9c9dd5e6c87b558a214a06a822851
parent955e0713f57ecdd576e4c7f378202ad1b741526f (diff)
version 0.3.120.3.12
-rw-r--r--prelude/prelude.purs48
-rw-r--r--purescript.cabal2
-rw-r--r--src/Language/PureScript.hs2
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs44
-rw-r--r--src/Language/PureScript/Pretty/JS.hs3
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs49
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs4
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs117
-rw-r--r--src/Language/PureScript/Types.hs63
9 files changed, 279 insertions, 53 deletions
diff --git a/prelude/prelude.purs b/prelude/prelude.purs
index 7959f73..b830d44 100644
--- a/prelude/prelude.purs
+++ b/prelude/prelude.purs
@@ -54,6 +54,13 @@ module Prelude where
instance Read Boolean where
read "true" = true
read _ = false
+
+ foreign import readNumber "function readNumber(n) {\
+ \ return parseInt(n, 10);\
+ \}" :: String -> Number
+
+ instance Read Number where
+ read = readNumber
infixl 4 <$>
@@ -362,6 +369,10 @@ module Monoid where
instance Monoid String where
mempty = ""
(<>) = (++)
+
+ instance Monoid [a] where
+ mempty = []
+ (<>) = Arrays.concat
mconcat :: forall m. (Monoid m) => [m] -> m
mconcat [] = mempty
@@ -429,22 +440,52 @@ module Maybe where
fromMaybe :: forall a. a -> Maybe a -> a
fromMaybe a = maybe a (Prelude.id :: forall a. a -> a)
+
+ instance Prelude.Functor Maybe where
+ (<$>) fn (Just x) = Just (fn x)
+ (<$>) _ _ = Nothing
+
+ instance Prelude.Applicative Maybe where
+ pure = Just
+ (<*>) (Just fn) x = fn <$> x
+ (<*>) Nothing _ = Nothing
instance Prelude.Monad Maybe where
return = Just
(>>=) m f = maybe Nothing f m
+
+ instance (Show a) => Prelude.Show (Maybe a) where
+ show (Just x) = "Just " ++ (show x)
+ show Nothing = "Nothing"
module Either where
+ import Prelude
+
data Either a b = Left a | Right b
either :: forall a b c. (a -> c) -> (b -> c) -> Either a b -> c
either f _ (Left a) = f a
either _ g (Right b) = g b
+
+ {-
+ instance Prelude.Functor (Either a) where
+ (<$>) _ (Left x) = Left x
+ (<$>) f (Right y) = Right (f y)
+ -}
+
+ instance Prelude.Applicative (Either e) where
+ pure = Right
+ (<*>) (Left e) _ = Left e
+ (<*>) (Right f) r = f <$> r
instance Prelude.Monad (Either e) where
return = Right
(>>=) = either (\e _ -> Left e) (\a f -> f a)
+
+ instance (Show a, Show b) => Prelude.Show (Either a b) where
+ show (Left x) = "Left " ++ (show x)
+ show (Right y) = "Right " ++ (show y)
module Arrays where
@@ -578,7 +619,7 @@ module Arrays where
range lo hi = {
var ns = [];
for (n <- lo until hi) {
- ns = push ns n;
+ ns = push ns n;
}
return ns;
}
@@ -598,7 +639,10 @@ module Arrays where
instance (Prelude.Show a) => Prelude.Show [a] where
show [] = "[]"
show (x:xs) = show x ++ " : " ++ show xs
-
+
+ instance Prelude.Functor [] where
+ (<$>) = map
+
instance Prelude.Monad [] where
return = singleton
(>>=) = concatMap
diff --git a/purescript.cabal b/purescript.cabal
index 268dfbf..581f926 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.3.11
+version: 0.3.12
cabal-version: >=1.8
build-type: Simple
license: MIT
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index fce4c95..34dbb02 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -67,4 +67,4 @@ compile opts ms = do
Left "Main.main is undefined"
return $ js ++ [JSApp (JSAccessor "main" (JSVar "Main")) []]
| otherwise -> return js
- return (prettyPrintJS js', exts, env)
+ return (prettyPrintJS [(wrapExportsContainer js')], exts, env)
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 616e8fb..3cce144 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -18,12 +18,15 @@
module Language.PureScript.CodeGen.JS (
module AST,
declToJs,
- moduleToJs
+ moduleToJs,
+ wrapExportsContainer
) where
import Data.Maybe (fromMaybe, mapMaybe)
import Data.List (sortBy)
import Data.Function (on)
+import Data.Data (Data)
+import Data.Generics (mkQ, everything)
import Control.Arrow (second)
import Control.Monad (replicateM, forM)
@@ -55,6 +58,7 @@ moduleToJs opts (Module pname@(ProperName name) decls) env =
(JSBlock (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts (ModuleName pname) decl env) (decls))))
[JSAssignment (JSVar name)
(JSBinary Or (JSVar name) (JSObjectLiteral []))]
+ , JSAssignment (JSAccessor name (JSVar "exports")) (JSVar name)
]
-- |
@@ -141,11 +145,20 @@ valueToJs _ _ _ (TypeClassDictionary _ _) = error "Type class dictionary was not
valueToJs _ _ _ _ = error "Invalid argument to valueToJs"
-- |
--- Temporarily extends the environment to include a local variable name introduced by a lambda
--- abstraction.
+-- Temporarily extends the environment with a single local variable name
--
bindName :: ModuleName -> Ident -> Environment -> Environment
-bindName m ident env = env { names = M.insert (m, ident) (error "Temporary lambda variable type was read", LocalVariable) $ names env }
+bindName m ident = bindNames m [ident]
+
+-- |
+-- Temporarily extends the environment to include local variable names introduced by lambda
+-- abstractions or case statements
+--
+bindNames :: ModuleName -> [Ident] -> Environment -> Environment
+bindNames m idents env = env { names = M.fromList [ ((m, ident), (noType, LocalVariable)) | ident <- idents ] `M.union` names env }
+ where
+ noType = error "Temporary lambda variable type was read"
+
-- |
-- Generate code in the simplified Javascript intermediate representation for runtime type checks.
@@ -213,7 +226,7 @@ qualifiedToJS f (Qualified Nothing a) = JSVar $ identToJs (f a)
bindersToJs :: Options -> ModuleName -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> JS
bindersToJs opts m e binders vals = runGen (map identToJs (unusedNames (binders, vals))) $ do
valNames <- replicateM (length vals) fresh
- jss <- forM binders $ \(bs, grd, result) -> go valNames [JSReturn (valueToJs opts m e result)] bs grd
+ jss <- forM binders $ \(bs, grd, result) -> go valNames [JSReturn (valueToJs opts m (bindNames m (binderNames bs) e) result)] bs grd
return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
vals
where
@@ -226,6 +239,15 @@ bindersToJs opts m e binders vals = runGen (map identToJs (unusedNames (binders,
go _ _ _ _ = error "Invalid arguments to bindersToJs"
-- |
+-- Collect all names introduced in binders in an expression
+--
+binderNames :: (Data d) => d -> [Ident]
+binderNames = everything (++) (mkQ [] go)
+ where
+ go (VarBinder ident) = [ident]
+ go _ = []
+
+-- |
-- Generate code in the simplified Javascript intermediate representation for a pattern match
-- binder.
--
@@ -239,7 +261,7 @@ binderToJs _ _ varName done (BooleanBinder True) =
return [JSIfElse (JSVar varName) (JSBlock done) Nothing]
binderToJs _ _ varName done (BooleanBinder False) =
return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
-binderToJs _ _ varName done (VarBinder ident) =
+binderToJs m e varName done (VarBinder ident) =
return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)
binderToJs m e varName done (NullaryBinder ctor) =
if isOnlyConstructor m e ctor
@@ -294,7 +316,7 @@ binderToJs m e varName done (NamedBinder ident binder) = do
-- |
-- Checks whether a data constructor is the only constructor for that type, used to simplify the
--- check when generating code for binders.
+-- check when generating code for binders.
--
isOnlyConstructor :: ModuleName -> Environment -> Qualified ProperName -> Bool
isOnlyConstructor m e ctor =
@@ -325,3 +347,11 @@ statementToJs opts m e (If ifst) = ifToJs ifst
elseToJs (Else sts) = JSBlock (map (statementToJs opts m e) sts)
elseToJs (ElseIf elif) = ifToJs elif
statementToJs opts m e (Return value) = JSReturn (valueToJs opts m e value)
+
+wrapExportsContainer :: [JS] -> JS
+wrapExportsContainer modules = JSApp (JSFunction Nothing ["exports"] $ JSBlock $ (JSStringLiteral "use strict") : modules) [exportSelector]
+ where exportSelector = JSConditional (JSBinary And (JSBinary NotEqualTo (JSTypeOf $ JSVar "module") (JSStringLiteral "undefined")) (JSAccessor "exports" (JSVar "module")))
+ (JSAccessor "exports" (JSVar "module"))
+ (JSConditional (JSBinary NotEqualTo (JSTypeOf $ JSVar "window") (JSStringLiteral "undefined"))
+ (JSAssignment (JSAccessor "PS" (JSVar "window")) (JSObjectLiteral []))
+ (JSApp (JSFunction Nothing [] $ JSBlock [JSThrow $ JSStringLiteral "PureScript doesn't know how to export modules in the current environment"]) []))
diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs
index 92e3bae..35bf7e3 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -69,6 +69,7 @@ literals = mkPattern' match
, fmap (intercalate ", ") $ forM xs prettyPrintJS'
, return " ]"
]
+ match (JSObjectLiteral []) = return "{}"
match (JSObjectLiteral ps) = fmap concat $ sequence
[ return "{\n"
, withIndent $ do
@@ -107,7 +108,7 @@ literals = mkPattern' match
, prettyPrintJS' sts
]
match (JSFor ident start end sts) = fmap concat $ sequence
- [ return $ "for (" ++ ident ++ " = "
+ [ return $ "for (var " ++ ident ++ " = "
, prettyPrintJS' start
, return $ "; " ++ ident ++ " < "
, prettyPrintJS' end
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index f6f9199..40a35fc 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -31,6 +31,8 @@ import qualified Data.Map as M
import Control.Applicative
import Control.Monad.State
+import Control.Arrow ((***))
+
import Data.Maybe (fromMaybe)
import Data.List (nub)
import Data.Generics (mkQ, everything)
@@ -50,6 +52,44 @@ desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
desugarModule :: Module -> Desugar Module
desugarModule (Module name decls) = Module name <$> concat <$> mapM (desugarDecl (ModuleName name)) decls
+-- |
+-- Desugar type class and type class instance declarations
+--
+-- Type classes become type synonyms for their dictionaries, and type instances become dictionary declarations.
+-- Additional values are generated to access individual members of a dictionary, with the appropriate type.
+--
+-- E.g. the following
+--
+-- module Test where
+--
+-- class Foo a where
+-- foo :: a -> a
+--
+-- instance Foo String where
+-- foo s = s ++ s
+--
+-- instance (Foo a) => Foo [a] where
+-- foo = map foo
+--
+-- becomes
+--
+-- type Foo a = { foo :: a -> a }
+--
+-- foreign import foo "function foo(dict) {\
+-- \ return dict.foo;\
+-- \}" :: forall a. (Foo a) => a -> a
+--
+-- __Test_Foo_string_foo = (\s -> s ++ s) :: String -> String
+--
+-- __Test_Foo_string :: Foo String
+-- __Test_Foo_string = { foo: __Test_Foo_string_foo :: String -> String (unchecked) }
+--
+-- __Test_Foo_array_foo :: forall a. (Foo a) => [a] -> [a]
+-- __Test_Foo_array_foo _1 = map (foo _1)
+--
+-- __Test_Foo_array :: forall a. Foo a -> Foo [a]
+-- __Test_Foo_array _1 = { foo: __Test_Foo_array_foo _1 :: [a] -> [a] (unchecked) }
+--
desugarDecl :: ModuleName -> Declaration -> Desugar [Declaration]
desugarDecl mn d@(TypeClassDeclaration name arg members) = do
let tys = map memberToNameAndType members
@@ -82,7 +122,7 @@ typeInstanceDictionaryDeclaration mn deps name ty decls = do
m <- get
(arg, instanceTys) <- lift $ maybe (Left $ "Type class " ++ show name ++ " is undefined. Type class names must be qualified.") Right
$ M.lookup (qualify mn name) m
- let memberTypes = map (replaceTypeVars arg ty) instanceTys
+ let memberTypes = map (id *** replaceTypeVars arg ty) instanceTys
entryName <- lift $ mkDictionaryValueName mn name ty
memberNames <- mapM (memberToNameAndValue memberTypes) decls
return $ ValueDeclaration entryName [] Nothing
@@ -119,13 +159,6 @@ qualifiedToString :: ModuleName -> Qualified ProperName -> String
qualifiedToString mn (Qualified Nothing pn) = qualifiedToString mn (Qualified (Just mn) pn)
qualifiedToString _ (Qualified (Just (ModuleName mn)) pn) = runProperName mn ++ "_" ++ runProperName pn
-quantify :: Type -> Type
-quantify ty' = foldr (\arg t -> ForAll arg t Nothing) ty' tyVars
- where
- tyVars = nub $ everything (++) (mkQ [] collect) ty'
- collect (TypeVar v) = [v]
- collect _ = []
-
-- |
-- Generate a name for a type class dictionary, based on the module name, class name and type name
--
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index dbeb44b..3283520 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -59,7 +59,9 @@ instance Unifiable Check Kind where
-- Infer the kind of a single type
--
kindOf :: ModuleName -> Type -> Check Kind
-kindOf moduleName ty = fmap tidyUp . liftUnify $ starIfUnknown <$> infer ty
+kindOf moduleName ty =
+ rethrow (("Error checking kind of " ++ prettyPrintType ty ++ ":\n") ++) $
+ fmap tidyUp . liftUnify $ starIfUnknown <$> infer ty
where
tidyUp (k, sub) = sub $? k
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 2cf7aec..7ffdeaf 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -67,7 +67,6 @@ import Control.Arrow (Arrow(..))
import qualified Data.Map as M
import Data.Function (on)
-import Debug.Trace (trace)
instance Partial Type where
unknown = TUnknown
@@ -167,41 +166,73 @@ typeConstructorsAreEqual env moduleName = (==) `on` canonicalizeType moduleName
typesOf :: ModuleName -> [(Ident, Value)] -> Check [(Ident, (Value, Type))]
typesOf moduleName vals = do
tys <- fmap tidyUp . liftUnify $ do
- let es = map isTyped vals
- typed = filter (isJust . snd . snd) es
- untyped = filter (isNothing . snd . snd) es
- typedDict = map (\(ident, (_, Just ty)) -> (ident, ty)) typed
+ let
+ -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed
+ es = map isTyped vals
+ -- Filter the typed and untyped declarations
+ typed = filter (isJust . snd . snd) es
+ untyped = filter (isNothing . snd . snd) es
+ -- Make a map of names to typed declarations
+ typedDict = map (\(ident, (_, Just (ty, _))) -> (ident, ty)) typed
+ -- Create fresh unification variables for the types of untyped declarations
untypedNames <- replicateM (length untyped) fresh
- let untypedDict = zip (map fst untyped) untypedNames
- dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ (map (id *** fst) typedDict) ++ untypedDict)
- forM es $ \e -> do
+ let
+ -- Make a map of names to the unification variables of untyped declarations
+ untypedDict = zip (map fst untyped) untypedNames
+ -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking
+ dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ typedDict ++ untypedDict)
+ forM es $ \e@(_, (val, _)) -> do
+ -- If the declaration is a function, it has access to other values in the binding group.
+ -- If not, the generated code might fail at runtime since those values might be undefined.
+ let dict' = if isFunction val then dict else M.empty
triple@(_, (val, ty)) <- case e of
+ -- Typed declarations
(ident, (val, Just (ty, checkType))) -> do
+ -- Kind check
kind <- liftCheck $ kindOf moduleName ty
guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
+ -- Check the type with the new names in scope
ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
- val' <- bindNames dict $ if checkType
+ val' <- bindNames dict' $ if checkType
then TypedValue True <$> check val ty' <*> pure ty'
else return (TypedValue False val ty')
return (ident, (val', ty'))
+ -- Untyped declarations
(ident, (val, Nothing)) -> do
- TypedValue _ val' ty <- bindNames dict $ infer val
+ -- Infer the type with the new names in scope
+ TypedValue _ val' ty <- bindNames dict' $ infer val
ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
return (ident, (TypedValue True val' ty, ty))
+ -- If run-main is enabled, need to check that Main.main has type Eff eff a for some eff, a
when (moduleName == ModuleName (ProperName "Main") && fst e == Ident "main") $ do
[eff, a] <- replicateM 2 fresh
ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName (ProperName "Eff"))) (ProperName "Eff"))) eff) a
+ -- Make sure unification variables do not escape
escapeCheck val ty
return triple
forM tys $ \(ident, (val, ty)) -> do
+ -- Replace type class dictionary placeholders with actual dictionaries
val' <- replaceTypeClassDictionaries moduleName val
- rethrow (("Error in " ++ show ident ++ ": \n") ++) $ skolemEscapeCheck val'
- return $ (ident, (overTypes (desaturateAllTypeSynonyms . setifyAll) $ val'
- , varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty))
+ -- Check skolem variables did not escape their scope
+ skolemEscapeCheck val'
+ -- Remove type synonyms placeholders, remove duplicate row fields, and replace
+ -- top-level unification variables with named type variables.
+ let val'' = overTypes (desaturateAllTypeSynonyms . setifyAll) val'
+ ty' = varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty
+ return $ (ident, (val'', ty'))
where
+ -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts
-- |
+-- Check if a value introduces a function
+--
+isFunction :: Value -> Bool
+isFunction (Abs _ _) = True
+isFunction (TypedValue _ val _) = isFunction val
+isFunction _ = False
+
+-- |
-- Check if a value contains a type annotation
--
isTyped :: (Ident, Value) -> (Ident, (Value, Maybe (Type, Bool)))
@@ -237,22 +268,33 @@ entails moduleName context goal@(className, ty) = do
go env (className', ty') =
[ mkDictionary (canonicalizeDictionary tcd) args
| tcd <- context
+ -- Choose type class dictionaries in scope in the current module
, filterModule tcd
+ -- Make sure the type class name matches the one we are trying to satisfy
, typeConstructorsAreEqual env moduleName className' (tcdClassName tcd)
+ -- Make sure the type unifies with the type in the type instance definition
, subst <- maybeToList $ typeHeadsAreEqual moduleName env ty' (tcdInstanceType tcd)
+ -- Solve any necessary subgoals
, args <- solveSubgoals env subst (tcdDependencies tcd) ]
+ -- 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 :: Environment -> [(String, Type)] -> Maybe [(Qualified ProperName, Type)] -> [Maybe [Value]]
solveSubgoals _ _ Nothing = return Nothing
solveSubgoals env subst (Just subgoals) = do
- dict <- mapM (go env) (replaceAllTypeVars subst subgoals)
+ dict <- mapM (go env) (map (id *** replaceAllTypeVars subst) subgoals)
return $ Just dict
+ -- Make a dictionary from subgoal dictionaries by applying the correct function
mkDictionary :: Qualified Ident -> Maybe [Value] -> Value
mkDictionary fnName Nothing = Var fnName
mkDictionary fnName (Just dicts) = foldl App (Var fnName) dicts
+ -- 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
+ -- Resolve a type class dictionary in scope to an actual value by following any (TCDAlias) pointers
+ -- which originated from module imports
canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident
canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm
canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm
@@ -268,6 +310,9 @@ typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]
typeHeadsAreEqual m e (TypeConstructor c1) (TypeConstructor c2) | typeConstructorsAreEqual e m c1 c2 = Just []
typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2
typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1
+typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e m name args of
+ Left err -> Nothing
+ Right t1 -> typeHeadsAreEqual m e t1 t2
typeHeadsAreEqual _ _ _ _ = Nothing
-- |
@@ -297,6 +342,12 @@ findAllTypes = everything (++) (mkQ [] go)
skolemEscapeCheck :: Value -> 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.
case everythingWithContext [] (++) (mkQ ((,) []) go) root of
[] -> return ()
((binding, val) : _) -> throwError $ "Rigid/skolem type variable bound by " ++ maybe "<unknown>" prettyPrintValue binding ++ " has escaped at " ++ prettyPrintValue val
@@ -348,11 +399,15 @@ varIfUnknown ty =
-- |
-- Replace named type variables with types
--
-replaceAllTypeVars :: (D.Data d) => [(String, Type)] -> d -> d
+replaceAllTypeVars :: [(String, Type)] -> Type -> Type
replaceAllTypeVars = foldl' (\f (name, ty) -> replaceTypeVars name ty . f) id
-- |
--- Replace named type variables with new unification variables
+-- Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns
+-- or TypeClassDictionary values.
+--
+-- This is necessary during type checking to avoid unifying a polymorphic type with a
+-- unification variable.
--
instantiatePolyTypeWithUnknowns :: Value -> Type -> UnifyT Type Check (Value, Type)
instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do
@@ -378,12 +433,18 @@ replaceVarWithUnknown ident ty = do
-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate
-- better error messages during unification.
--
-replaceAllTypeSynonyms :: (Functor m, MonadState CheckState m, MonadError String m) => (D.Data d) => d -> m d
+replaceAllTypeSynonyms' :: (D.Data d) => Environment -> ModuleName -> d -> Either String d
+replaceAllTypeSynonyms' env moduleName d =
+ let
+ syns = map (\((path, name), (args, _)) -> ((path, name), length args)) . M.toList $ typeSynonyms env
+ in
+ saturateAllTypeSynonyms env moduleName syns d
+
+replaceAllTypeSynonyms :: (Functor m, Monad m, MonadState CheckState m, MonadError String m) => (D.Data d) => d -> m d
replaceAllTypeSynonyms d = do
env <- getEnv
Just moduleName <- checkCurrentModule <$> get
- let syns = map (\((path, name), (args, _)) -> ((path, name), length args)) . M.toList $ typeSynonyms env
- either throwError return $ saturateAllTypeSynonyms env moduleName syns d
+ either throwError return $ replaceAllTypeSynonyms' env moduleName d
-- |
-- \"Desaturate\" @SaturatedTypeSynonym@s
@@ -397,13 +458,19 @@ desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)
-- |
-- Replace a type synonym and its arguments with the aliased type
--
-expandTypeSynonym :: Qualified ProperName -> [Type] -> UnifyT Type Check Type
+expandTypeSynonym' :: Environment -> ModuleName -> Qualified ProperName -> [Type] -> Either String Type
+expandTypeSynonym' env moduleName name args =
+ case M.lookup (canonicalizeType moduleName env name) (typeSynonyms env) of
+ Just (synArgs, body) -> do
+ let repl = replaceAllTypeVars (zip synArgs args) body
+ replaceAllTypeSynonyms' env moduleName repl
+ Nothing -> error "Type synonym was not defined"
+
+expandTypeSynonym :: (Functor m, Monad m, MonadState CheckState m, MonadError String m) => Qualified ProperName -> [Type] -> m Type
expandTypeSynonym name args = do
env <- getEnv
Just moduleName <- checkCurrentModule <$> get
- case M.lookup (canonicalizeType moduleName env name) (typeSynonyms env) of
- Just (synArgs, body) -> return $ replaceAllTypeVars (zip synArgs args) body
- Nothing -> error "Type synonym was not defined"
+ either throwError return $ expandTypeSynonym' env moduleName name args
-- |
-- Ensure a set of property names and value does not contain duplicate labels
@@ -693,8 +760,8 @@ newSkolemScope = SkolemScope . runUnknown <$> fresh'
-- |
-- Skolemize a type variable by replacing its instances with fresh skolem constants
--
-skolemize :: (D.Data d) => String -> Int -> SkolemScope -> d -> d
-skolemize ident sko scope d = replaceTypeVars ident (Skolem sko scope) d
+skolemize :: String -> Int -> SkolemScope -> Type -> Type
+skolemize ident sko scope = replaceTypeVars ident (Skolem sko scope)
-- |
-- Introduce skolem scope at every occurence of a ForAll
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index 0bec97e..c5e9dff 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -18,9 +18,11 @@
module Language.PureScript.Types where
import Data.Data
-import Data.Generics (mkT, mkQ, everywhereBut)
+import Data.List (nub)
+import Data.Generics (everything, mkT, mkQ, everywhereBut)
import Control.Monad.Unify
+import Control.Arrow ((***))
import Language.PureScript.Names
@@ -159,10 +161,57 @@ unit = Object REmpty
-- |
-- Replace a type variable, taking into account variable shadowing
--
-replaceTypeVars :: (Data d) => String -> Type -> d -> d
-replaceTypeVars name t = everywhereBut (mkQ False isShadowed) (mkT replaceTypeVar)
+replaceTypeVars :: String -> Type -> Type -> Type
+replaceTypeVars = replaceTypeVars' []
where
- replaceTypeVar (TypeVar v) | v == name = t
- replaceTypeVar other = other
- isShadowed (ForAll v _ _) | v == name = True
- isShadowed _ = False
+ replaceTypeVars' bound name replacement = go bound
+ where
+ go :: [String] -> Type -> Type
+ go bs (Object r) = Object $ go bs r
+ go bs (TypeVar v) | v == name = replacement
+ go bs (TypeApp t1 t2) = TypeApp (go bs t1) (go bs t2)
+ go bs (SaturatedTypeSynonym name ts) = SaturatedTypeSynonym name $ map (go bs) ts
+ go bs f@(ForAll v t sco) | v == name = f
+ | v `elem` usedTypeVariables replacement =
+ let v' = genName v (name : bs ++ usedTypeVariables replacement)
+ t' = replaceTypeVars' bs v (TypeVar v') t
+ in ForAll v' (go (v' : bs) t') sco
+ | otherwise = ForAll v (go (v : bs) t) sco
+ go bs (ConstrainedType cs t) = ConstrainedType (map (id *** go bs) cs) (go bs t)
+ go bs (RCons name t r) = RCons name (go bs t) (go bs r)
+ go _ ty = ty
+ genName orig inUse = try 0
+ where
+ try n | (orig ++ show n) `elem` inUse = try (n + 1)
+ | otherwise = orig ++ show n
+
+-- |
+-- Collect all type variables appearing in a type
+--
+usedTypeVariables :: Type -> [String]
+usedTypeVariables = nub . everything (++) (mkQ [] go)
+ where
+ go (TypeVar v) = [v]
+ go _ = []
+
+-- |
+-- Collect all free type variables appearing in a type
+--
+freeTypeVariables :: Type -> [String]
+freeTypeVariables = nub . go []
+ where
+ go :: [String] -> Type -> [String]
+ go bound (Object r) = go bound r
+ go bound (TypeVar v) | v `notElem` bound = [v]
+ go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2
+ go bound (SaturatedTypeSynonym _ ts) = concatMap (go bound) ts
+ go bound (ForAll v t _) = go (v : bound) t
+ go bound (ConstrainedType cs t) = concatMap (go bound . snd) cs ++ go bound t
+ go bound (RCons _ t r) = go bound t ++ go bound r
+ go _ _ = []
+
+-- |
+-- Universally quantify over all type variables appearing free in a type
+--
+quantify :: Type -> Type
+quantify ty = foldr (\arg t -> ForAll arg t Nothing) ty $ freeTypeVariables ty