summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-01-07 23:07:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-01-07 23:07:00 (GMT)
commit57b6d9b2e8978c8b7e70cad2070205359ae1978d (patch)
tree94c33e4d16e6df37d30ad798a14138d5060834af
parent94e5e17d8cf671bd60064c2482d5fbcea8bfdb43 (diff)
version 0.2.40.2.4
-rw-r--r--purescript.cabal2
-rw-r--r--src/Language/PureScript/BindingGroups.hs2
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs3
-rw-r--r--src/Language/PureScript/Declarations.hs12
-rw-r--r--src/Language/PureScript/Kinds.hs3
-rw-r--r--src/Language/PureScript/Parser/Common.hs8
-rw-r--r--src/Language/PureScript/Parser/Kinds.hs9
-rw-r--r--src/Language/PureScript/Parser/Types.hs17
-rw-r--r--src/Language/PureScript/Parser/Values.hs6
-rw-r--r--src/Language/PureScript/Pretty/Kinds.hs11
-rw-r--r--src/Language/PureScript/Pretty/Types.hs16
-rw-r--r--src/Language/PureScript/Pretty/Values.hs2
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs36
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs101
-rw-r--r--src/Language/PureScript/Types.hs21
-rw-r--r--src/Language/PureScript/Values.hs2
16 files changed, 119 insertions, 132 deletions
diff --git a/purescript.cabal b/purescript.cabal
index 40f9892..25054eb 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.2.3
+version: 0.2.4
cabal-version: >=1.8
build-type: Simple
license: MIT
diff --git a/src/Language/PureScript/BindingGroups.hs b/src/Language/PureScript/BindingGroups.hs
index 5fe000d..9740936 100644
--- a/src/Language/PureScript/BindingGroups.hs
+++ b/src/Language/PureScript/BindingGroups.hs
@@ -93,6 +93,6 @@ fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val)
fromValueDecl (ValueDeclaration _ _ _ _) = error "Binders should have been desugared"
fromValueDecl _ = error "Expected ValueDeclaration"
-fromDataDecl :: Declaration -> (ProperName, [String], [(ProperName, Maybe PolyType)])
+fromDataDecl :: Declaration -> (ProperName, [String], [(ProperName, Maybe Type)])
fromDataDecl (DataDeclaration pn args ctors) = (pn, args, ctors)
fromDataDecl _ = error "Expected DataDeclaration"
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index ba09b41..661c88f 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -43,9 +43,6 @@ moduleToJs (Module pname@(ProperName name) decls) env =
]
declToJs :: ModuleName -> Declaration -> Environment -> Maybe [JS]
-declToJs mp (ValueDeclaration ident _ _ (Abs args ret)) e =
- Just [ JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs mp e ret)]),
- setProperty (identToJs ident) (JSVar ident) mp ]
declToJs mp (ValueDeclaration ident _ _ val) e =
Just [ JSVariableIntroduction ident (Just (valueToJs mp e val)),
setProperty (identToJs ident) (JSVar ident) mp ]
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
index 89f744f..34bb8c5 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -32,14 +32,14 @@ data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable
data Module = Module ProperName [Declaration] deriving (Show, D.Data, D.Typeable)
data Declaration
- = DataDeclaration ProperName [String] [(ProperName, Maybe PolyType)]
- | DataBindingGroupDeclaration [(ProperName, [String], [(ProperName, Maybe PolyType)])]
- | TypeSynonymDeclaration ProperName [String] PolyType
- | TypeDeclaration Ident PolyType
+ = DataDeclaration ProperName [String] [(ProperName, Maybe Type)]
+ | DataBindingGroupDeclaration [(ProperName, [String], [(ProperName, Maybe Type)])]
+ | TypeSynonymDeclaration ProperName [String] Type
+ | TypeDeclaration Ident Type
| ValueDeclaration Ident [[Binder]] (Maybe Guard) Value
| BindingGroupDeclaration [(Ident, Value)]
- | ExternDeclaration Ident PolyType
- | ExternMemberDeclaration String Ident PolyType
+ | ExternDeclaration Ident Type
+ | ExternMemberDeclaration String Ident Type
| ExternDataDeclaration ProperName Kind
| FixityDeclaration Fixity String
| ImportDeclaration ModuleName (Maybe [Either Ident ProperName])
diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs
index 222338c..92f9f4e 100644
--- a/src/Language/PureScript/Kinds.hs
+++ b/src/Language/PureScript/Kinds.hs
@@ -22,5 +22,6 @@ import Language.PureScript.Unknown
data Kind
= KUnknown (Unknown Kind)
| Star
- | Row
+ | Bang
+ | Row Kind
| FunKind Kind Kind deriving (Show, Eq, Data, Typeable)
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index 1e32d5f..912bb25 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -77,10 +77,10 @@ builtInOperators = [ "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "
, "==", "!=", "&&", "||", "&", "^", "|", "!!", "!" ]
reservedOpNames :: [String]
-reservedOpNames = builtInOperators ++ [ "->", "=", "." ]
+reservedOpNames = builtInOperators ++ [ "->", "=", ".", "\\" ]
identStart :: P.Parsec String u Char
-identStart = P.lower <|> P.oneOf "_$"
+identStart = P.lower <|> P.oneOf "_"
properNameStart :: P.Parsec String u Char
properNameStart = P.upper
@@ -89,10 +89,10 @@ identLetter :: P.Parsec String u Char
identLetter = P.alphaNum <|> P.oneOf "_'"
opStart :: P.Parsec String u Char
-opStart = P.oneOf ":.!#%&*+/<=>?@^|~"
+opStart = P.oneOf ":!#$%&*+./<=>?@\\^|-~"
opLetter :: P.Parsec String u Char
-opLetter = P.oneOf ":.#$%&*+./<=>?@^|"
+opLetter = P.oneOf ":!#$%&*+./<=>?@\\^|-~"
langDef :: PT.GenLanguageDef String u Identity
langDef = PT.LanguageDef
diff --git a/src/Language/PureScript/Parser/Kinds.hs b/src/Language/PureScript/Parser/Kinds.hs
index 38305ef..cb88e52 100644
--- a/src/Language/PureScript/Parser/Kinds.hs
+++ b/src/Language/PureScript/Parser/Kinds.hs
@@ -26,16 +26,17 @@ import qualified Text.Parsec.Expr as P
parseStar :: P.Parsec String ParseState Kind
parseStar = const Star <$> lexeme (P.char '*')
-parseRow :: P.Parsec String ParseState Kind
-parseRow = const Row <$> lexeme (P.char '#')
+parseBang :: P.Parsec String ParseState Kind
+parseBang = const Bang <$> lexeme (P.char '!')
parseTypeAtom :: P.Parsec String ParseState Kind
parseTypeAtom = indented *> P.choice (map P.try
[ parseStar
- , parseRow
+ , parseBang
, parens parseKind ])
parseKind :: P.Parsec String ParseState Kind
parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind"
where
- operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return FunKind) P.AssocRight ] ]
+ operators = [ [ P.Prefix (lexeme (P.char '#') >> return Row) ]
+ , [ P.Infix (lexeme (P.try (P.string "->")) >> return FunKind) P.AssocRight ] ]
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
index d2bb873..679b162 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -69,6 +69,7 @@ parseTypeAtom = indented *> P.choice (map P.try
, parseTypeVariable
, parseTypeConstructor
, parseForAll
+ , parens parseRow
, parens parseType ])
parseAnyType :: P.Parsec String ParseState Type
@@ -84,21 +85,21 @@ parseType = do
unless (isMonoType ty) $ P.unexpected "polymorphic type"
return ty
-parsePolyType :: P.Parsec String ParseState PolyType
+parsePolyType :: P.Parsec String ParseState Type
parsePolyType = do
ty <- parseAnyType
unless (isPolyType ty) $ P.unexpected "polymorphic type"
return ty
-parseNameAndType :: P.Parsec String ParseState (String, Type)
-parseNameAndType = (,) <$> (indented *> identifier <* indented <* lexeme (P.string "::")) <*> parsePolyType
+parseNameAndType :: P.Parsec String ParseState t -> P.Parsec String ParseState (String, t)
+parseNameAndType p = (,) <$> (indented *> identifier <* indented <* lexeme (P.string "::")) <*> p
-parseRowEnding :: P.Parsec String ParseState Row
-parseRowEnding = P.option REmpty (RowVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier))
+parseRowEnding :: P.Parsec String ParseState Type
+parseRowEnding = P.option REmpty (TypeVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier))
-parseRow :: P.Parsec String ParseState Row
-parseRow = (fromList <$> (commaSep parseNameAndType) <*> parseRowEnding) P.<?> "row"
+parseRow :: P.Parsec String ParseState Type
+parseRow = (fromList <$> (commaSep $ parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row"
where
- fromList :: [(String, Type)] -> Row -> Row
+ fromList :: [(String, Type)] -> Type -> Type
fromList [] r = r
fromList ((name, t):ts) r = RCons name t (fromList ts r)
diff --git a/src/Language/PureScript/Parser/Values.hs b/src/Language/PureScript/Parser/Values.hs
index 465b5f2..9d17004 100644
--- a/src/Language/PureScript/Parser/Values.hs
+++ b/src/Language/PureScript/Parser/Values.hs
@@ -51,9 +51,9 @@ parseIdentifierAndValue = (,) <$> (C.indented *> C.identifier <* C.indented <* C
parseAbs :: P.Parsec String ParseState Value
parseAbs = do
- C.lexeme $ P.char '\\'
+ C.reservedOp "\\"
args <- P.many (C.indented *> (P.try singleArg <|> manyArgs))
- C.lexeme $ C.indented *> P.string "->"
+ C.indented *> C.reservedOp "->"
value <- parseValue
return $ toFunction args value
where
@@ -80,7 +80,7 @@ parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.rese
parseCaseAlternative :: P.Parsec String ParseState ([Binder], Maybe Guard, Value)
parseCaseAlternative = (,,) <$> (return <$> parseBinder)
<*> P.optionMaybe parseGuard
- <*> (C.lexeme (P.string "->") *> parseValue)
+ <*> (C.indented *> C.reservedOp "->" *> parseValue)
P.<?> "case alternative"
parseIfThenElse :: P.Parsec String ParseState Value
diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs
index 822d6a1..aa358fe 100644
--- a/src/Language/PureScript/Pretty/Kinds.hs
+++ b/src/Language/PureScript/Pretty/Kinds.hs
@@ -27,10 +27,16 @@ typeLiterals :: Pattern () Kind String
typeLiterals = mkPattern match
where
match Star = Just "*"
- match Row = Just "#"
+ match Bang = Just "!"
match (KUnknown (Unknown u)) = Just $ 'u' : show u
match _ = Nothing
+matchRow :: Pattern () Kind ((), Kind)
+matchRow = mkPattern match
+ where
+ match (Row k) = Just ((), k)
+ match _ = Nothing
+
funKind :: Pattern () Kind (Kind, Kind)
funKind = mkPattern match
where
@@ -44,4 +50,5 @@ prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind ()
matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)
operators :: OperatorTable () Kind String
operators =
- OperatorTable [ [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ]
+ OperatorTable [ [ Wrap matchRow $ \_ k -> "# " ++ k]
+ , [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ]
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index bd93195..79beb16 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -32,27 +32,29 @@ typeLiterals = mkPattern match
match String = Just "String"
match Boolean = Just "Boolean"
match (Array ty) = Just $ "[" ++ prettyPrintType ty ++ "]"
- match (Object row) = Just $ "{ " ++ prettyPrintRow row ++ " }"
+ match (Object row) = Just $ "{ " ++ prettyPrintType row ++ " }"
match (TypeVar var) = Just var
match (TypeConstructor ctor) = Just $ show ctor
match (TUnknown (Unknown u)) = Just $ 'u' : show u
match (Skolem s) = Just $ 's' : show s
match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"
match (ForAll ident ty) = Just $ "forall " ++ ident ++ ". " ++ prettyPrintType ty
+ match REmpty = Just $ prettyPrintRow REmpty
+ match row@(RCons _ _ _) = Just $ prettyPrintRow row
match _ = Nothing
-prettyPrintRow :: Row -> String
+prettyPrintRow :: Type -> String
prettyPrintRow = (\(tys, rest) -> intercalate ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs rest) . toList []
where
nameAndTypeToPs :: String -> Type -> String
nameAndTypeToPs name ty = name ++ " :: " ++ prettyPrintType ty
- tailToPs :: Row -> String
+ tailToPs :: Type -> String
tailToPs REmpty = ""
- tailToPs (RUnknown (Unknown u)) = " | u" ++ show u
- tailToPs (RowVar var) = " | " ++ var
- tailToPs (RSkolem s) = " | s" ++ show s
+ tailToPs (TUnknown (Unknown u)) = " | u" ++ show u
+ tailToPs (TypeVar var) = " | " ++ var
+ tailToPs (Skolem s) = " | s" ++ show s
tailToPs _ = error "Invalid row tail"
- toList :: [(String, Type)] -> Row -> ([(String, Type)], Row)
+ toList :: [(String, Type)] -> Type -> ([(String, Type)], Type)
toList tys (RCons name ty row) = toList ((name, ty):tys) row
toList tys r = (tys, r)
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index f9c6d81..c17579d 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -82,7 +82,7 @@ lam = mkPattern match
match (Abs args val) = Just (map show args, val)
match _ = Nothing
-typed :: Pattern () Value (PolyType, Value)
+typed :: Pattern () Value (Type, Value)
typed = mkPattern match
where
match (TypedValue val ty) = Just (ty, val)
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index 5b468ac..846faa6 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -12,6 +12,7 @@
--
-----------------------------------------------------------------------------
+{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Language.PureScript.TypeChecker.Kinds (
@@ -43,7 +44,8 @@ instance Unifiable Kind where
KUnknown u ~~ k = replace u k
k ~~ KUnknown u = replace u k
Star ~~ Star = return ()
- Row ~~ Row = return ()
+ Bang ~~ Bang = return ()
+ Row k1 ~~ Row k2 = k1 ~~ k2
FunKind k1 k2 ~~ FunKind k3 k4 = do
k1 ~~ k3
k2 ~~ k4
@@ -58,7 +60,7 @@ instance Unifiable Kind where
kindOf :: ModuleName -> Type -> Check Kind
kindOf moduleName ty = fmap (\(k, _, _) -> k) . runSubst (SubstContext moduleName) $ starIfUnknown <$> infer ty
-kindsOf :: ModuleName -> ProperName -> [String] -> [PolyType] -> Check Kind
+kindsOf :: ModuleName -> ProperName -> [String] -> [Type] -> Check Kind
kindsOf moduleName name args ts = fmap (starIfUnknown . (\(k, _, _) -> k)) . runSubst (SubstContext moduleName) $ do
tyCon <- fresh
kargs <- replicateM (length args) fresh
@@ -66,7 +68,7 @@ kindsOf moduleName name args ts = fmap (starIfUnknown . (\(k, _, _) -> k)) . run
bindLocalTypeVariables moduleName dict $
solveTypes ts kargs tyCon
-kindsOfAll :: ModuleName -> [(ProperName, [String], [PolyType])] -> Check [Kind]
+kindsOfAll :: ModuleName -> [(ProperName, [String], [Type])] -> Check [Kind]
kindsOfAll moduleName tys = fmap (map starIfUnknown . (\(ks, _, _) -> ks)) . runSubst (SubstContext moduleName) $ do
tyCons <- replicateM (length tys) fresh
let dict = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons
@@ -90,13 +92,16 @@ starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)
starIfUnknown k = k
infer :: Type -> Subst Kind
+infer Number = return Star
+infer String = return Star
+infer Boolean = return Star
infer (Array t) = do
k <- infer t
k ~~ Star
return Star
infer (Object row) = do
- k <- inferRow row
- k ~~ Row
+ k <- infer row
+ k ~~ Row Star
return Star
infer (Function args ret) = do
ks <- mapM infer args
@@ -123,17 +128,12 @@ infer (ForAll ident ty) = do
k <- fresh
moduleName <- substCurrentModule <$> ask
bindLocalTypeVariables moduleName [(ProperName ident, k)] $ infer ty
-infer _ = return Star
-
-inferRow :: Row -> Subst Kind
-inferRow (RowVar v) = do
- moduleName <- substCurrentModule <$> ask
- lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
-inferRow REmpty = return Row
-inferRow (RCons _ ty row) = do
+infer REmpty = do
+ k <- fresh
+ return $ Row k
+infer (RCons _ ty row) = do
k1 <- infer ty
- k2 <- inferRow row
- k1 ~~ Star
- k2 ~~ Row
- return Row
-inferRow _ = error "Invalid row in inferRow"
+ k2 <- infer row
+ k2 ~~ Row k1
+ return $ Row k1
+infer _ = error "Invalid argument to infer"
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 36c2b73..754e63b 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -12,6 +12,7 @@
--
-----------------------------------------------------------------------------
+{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}
module Language.PureScript.TypeChecker.Types (
@@ -23,7 +24,7 @@ import Data.Maybe (fromMaybe)
import Data.Either (lefts, rights)
import qualified Data.Data as D
import Data.Generics
- (mkT, something, everywhere, everywhereBut, mkQ, extQ)
+ (mkT, something, everywhere, everywhereBut, mkQ)
import Language.PureScript.Values
import Language.PureScript.Types
@@ -56,6 +57,7 @@ instance Unifiable Type where
apply s (Object r) = Object (apply s r)
apply s (Function args ret) = Function (map (apply s) args) (apply s ret)
apply s (TypeApp t1 t2) = TypeApp (apply s t1) (apply s t2)
+ apply s (RCons name ty r) = RCons name (apply s ty) (apply s r)
apply _ t = t
unknowns (TUnknown (Unknown u)) = [u]
unknowns (SaturatedTypeSynonym _ tys) = concatMap unknowns tys
@@ -64,40 +66,6 @@ instance Unifiable Type where
unknowns (Object r) = unknowns r
unknowns (Function args ret) = concatMap unknowns args ++ unknowns ret
unknowns (TypeApp t1 t2) = unknowns t1 ++ unknowns t2
- unknowns _ = []
-
-instance Unifiable Row where
- unknown = RUnknown
- isUnknown (RUnknown u) = Just u
- isUnknown _ = Nothing
- 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)] -> Row -> [(String, Type)] -> Row -> Subst ()
- unifyRows [] (RUnknown u) sd r = replace u (rowFromList (sd, r))
- unifyRows sd r [] (RUnknown u) = replace u (rowFromList (sd, r))
- unifyRows ((name, ty):row) r others u@(RUnknown un) = do
- occursCheck un ty
- forM row $ \(_, t) -> occursCheck un t
- u' <- fresh
- u ~~ RCons name ty u'
- unifyRows row r others u'
- unifyRows [] REmpty [] REmpty = return ()
- unifyRows [] (RowVar v1) [] (RowVar v2) | v1 == v2 = return ()
- unifyRows [] (RSkolem s1) [] (RSkolem s2) | s1 == s2 = return ()
- unifyRows sd3 r3 sd4 r4 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd3, r3)) ++ " with " ++ prettyPrintRow (rowFromList (sd4, r4)) ++ "."
- apply s (RUnknown u) = runSubstitution s u
- apply s (RCons name ty r) = RCons name (apply s ty) (apply s r)
- apply _ r = r
- unknowns (RUnknown (Unknown u)) = [u]
unknowns (RCons _ ty r) = unknowns ty ++ unknowns r
unknowns _ = []
@@ -140,8 +108,38 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +
t3 `unifyTypes` t5
t4 `unifyTypes` t6
unifyTypes' (Skolem s1) (Skolem s2) | s1 == s2 = return ()
+ 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' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."
+unifyRows :: Type -> Type -> Subst ()
+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 -> Subst ()
+ unifyRows' [] (TUnknown u) sd r = replace u (rowFromList (sd, r))
+ unifyRows' sd r [] (TUnknown u) = replace u (rowFromList (sd, r))
+ unifyRows' ((name, ty):row) r others u@(TUnknown un) = do
+ occursCheck un ty
+ forM row $ \(_, t) -> occursCheck un t
+ u' <- fresh
+ u ~~ RCons name ty u'
+ unifyRows' row r others u'
+ 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 $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd3, r3)) ++ " with " ++ prettyPrintRow (rowFromList (sd4, r4)) ++ "."
+
typeConstructorsAreEqual :: Environment -> ModuleName -> Qualified ProperName -> Qualified ProperName -> Bool
typeConstructorsAreEqual env moduleName c1 c2 =
let
@@ -197,16 +195,14 @@ escapeCheck checks ty sub =
skolemEscapeCheck :: Type -> Check ()
skolemEscapeCheck ty =
- case something (extQ (mkQ Nothing findSkolems) findRSkolems) ty of
+ case something (mkQ Nothing findSkolems) ty of
Nothing -> return ()
Just _ -> throwError "Skolem variables cannot escape. Consider adding a type signature."
where
findSkolems (Skolem _) = return ()
findSkolems _ = mzero
- findRSkolems (RSkolem _) = return ()
- findRSkolems _ = mzero
-setify :: Row -> Row
+setify :: Type -> Type
setify = rowFromList . first (M.toList . M.fromList) . rowToList
setifyAll :: (D.Data d) => d -> d
@@ -216,13 +212,10 @@ varIfUnknown :: Type -> Type
varIfUnknown ty =
let unks = nub $ unknowns ty
toName = (:) 't' . show
- ty' = everywhere (mkT rowToVar) . everywhere (mkT typeToVar) $ ty
+ ty' = everywhere (mkT typeToVar) $ ty
typeToVar :: Type -> Type
typeToVar (TUnknown (Unknown u)) = TypeVar (toName u)
typeToVar t = t
- rowToVar :: Row -> Row
- rowToVar (RUnknown (Unknown u)) = RowVar (toName u)
- rowToVar t = t
in mkForAll (sort . map toName $ unks) ty'
replaceAllTypeVars :: (D.Data d) => [(String, Type)] -> d -> d
@@ -236,12 +229,6 @@ replaceTypeVars name t = everywhereBut (mkQ False isShadowed) (mkT replaceTypeVa
isShadowed (ForAll v _) | v == name = True
isShadowed _ = False
-replaceRowVars :: (D.Data d) => String -> Row -> d -> d
-replaceRowVars name r = everywhere (mkT replaceRowVar)
- where
- replaceRowVar (RowVar v) | v == name = r
- replaceRowVar other = other
-
replaceAllVarsWithUnknowns :: Type -> Subst Type
replaceAllVarsWithUnknowns (ForAll ident ty) = replaceVarWithUnknown ident ty >>= replaceAllVarsWithUnknowns
replaceAllVarsWithUnknowns ty = return ty
@@ -249,8 +236,7 @@ replaceAllVarsWithUnknowns ty = return ty
replaceVarWithUnknown :: String -> Type -> Subst Type
replaceVarWithUnknown ident ty = do
tu <- fresh
- ru <- fresh
- return $ replaceRowVars ident ru . replaceTypeVars ident tu $ ty
+ return $ replaceTypeVars ident tu $ ty
replaceAllTypeSynonyms :: (Functor m, MonadState CheckState m, MonadReader SubstContext m, MonadError String m) => (D.Data d) => d -> m d
replaceAllTypeSynonyms d = do
@@ -487,7 +473,7 @@ inferBinder val (ObjectBinder props) = do
val ~~ Object row
return m1
where
- inferRowProperties :: Row -> Row -> [(String, Binder)] -> Subst (M.Map Ident Type)
+ inferRowProperties :: Type -> Type -> [(String, Binder)] -> Subst (M.Map Ident Type)
inferRowProperties nrow row [] = nrow ~~ row >> return M.empty
inferRowProperties nrow row ((name, binder):binders) = do
propTy <- fresh
@@ -597,8 +583,7 @@ checkBlock mass ret (s:ss) = do
skolemize :: String -> Type -> Subst Type
skolemize ident ty = do
tsk <- Skolem <$> fresh'
- rsk <- RSkolem <$> fresh'
- return $ replaceRowVars ident rsk $ replaceTypeVars ident tsk ty
+ return $ replaceTypeVars ident tsk ty
check :: Value -> Type -> Subst ()
check val ty = rethrow errorMessage $ check' val ty
@@ -683,15 +668,15 @@ check' val (SaturatedTypeSynonym name args) = do
check val ty
check' val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty
-checkProperties :: [(String, Value)] -> Row -> Bool -> Subst ()
+checkProperties :: [(String, Value)] -> Type -> Bool -> Subst ()
checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
go [] [] REmpty = return ()
- go [] [] u@(RUnknown _) = u ~~ REmpty
- go [] [] (RSkolem _) | lax = return ()
+ go [] [] u@(TUnknown _) = u ~~ REmpty
+ go [] [] (Skolem _) | lax = return ()
go [] ((p, _): _) _ | lax = return ()
| otherwise = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have property " ++ p
go ((p,_):_) [] REmpty = throwError $ "Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row
- go ((p,v):ps') [] u@(RUnknown _) = do
+ go ((p,v):ps') [] u@(TUnknown _) = do
ty <- infer v
rest <- fresh
u ~~ RCons p ty rest
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index 8028109..b85cc24 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -26,30 +26,23 @@ data Type
| String
| Boolean
| Array Type
- | Object Row
- | Function [PolyType] Type
+ | Object Type
+ | Function [Type] Type
| TypeVar String
| TypeConstructor (Qualified ProperName)
| TypeApp Type Type
| SaturatedTypeSynonym (Qualified ProperName) [Type]
| ForAll String Type
- | Skolem Int deriving (Show, Eq, Data, Typeable)
-
-type PolyType = Type
-
-data Row
- = RUnknown (Unknown Row)
- | RowVar String
+ | Skolem Int
| REmpty
- | RCons String Type Row
- | RSkolem Int deriving (Show, Eq, Data, Typeable)
+ | RCons String Type Type deriving (Show, Eq, Data, Typeable)
-rowToList :: Row -> ([(String, Type)], Row)
+rowToList :: Type -> ([(String, Type)], Type)
rowToList (RCons name ty row) = let (tys, rest) = rowToList row
- in ((name, ty):tys, rest)
+ in ((name, ty):tys, rest)
rowToList r = ([], r)
-rowFromList :: ([(String, Type)], Row) -> Row
+rowFromList :: ([(String, Type)], Type) -> Type
rowFromList ([], r) = r
rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))
diff --git a/src/Language/PureScript/Values.hs b/src/Language/PureScript/Values.hs
index 1e57a74..c26e0dc 100644
--- a/src/Language/PureScript/Values.hs
+++ b/src/Language/PureScript/Values.hs
@@ -70,7 +70,7 @@ data Value
| Block [Statement]
| Constructor (Qualified ProperName)
| Case [Value] [([Binder], Maybe Guard, Value)]
- | TypedValue Value PolyType deriving (Show, Data, Typeable)
+ | TypedValue Value Type deriving (Show, Data, Typeable)
data Statement
= VariableIntroduction Ident Value