diff --git a/prelude/prelude.purs b/prelude/prelude.purs --- a/prelude/prelude.purs +++ b/prelude/prelude.purs @@ -54,11 +54,11 @@ instance Read Boolean where read "true" = true read _ = false - + foreign import readNumber "function readNumber(n) {\ - \ return parseInt(n, 10);\ + \ return parseFloat(n);\ \}" :: String -> Number - + instance Read Number where read = readNumber @@ -164,13 +164,13 @@ foreign import refEq "function refEq(r1) {\ \ return function(r2) {\ - \ return r1.value === r2.value;\ + \ return r1.values[0] === r2.values[0];\ \ };\ \}" :: forall a. Ref a -> Ref a -> Boolean foreign import refIneq "function refIneq(r1) {\ \ return function(r2) {\ - \ return r1.value !== r2.value;\ + \ return r1.values[0] !== r2.values[0];\ \ };\ \}" :: forall a. Ref a -> Ref a -> Boolean @@ -369,7 +369,7 @@ instance Monoid String where mempty = "" (<>) = (++) - + instance Monoid [a] where mempty = [] (<>) = Arrays.concat @@ -440,11 +440,11 @@ fromMaybe :: forall a. a -> Maybe a -> a fromMaybe a = maybe a (Prelude.id :: forall a. a -> a) - + instance Prelude.Monad Maybe where return = Just (>>=) m f = maybe Nothing f m - + instance Prelude.Applicative Maybe where pure = Just (<*>) (Just fn) x = fn <$> x @@ -453,7 +453,7 @@ instance Prelude.Functor Maybe where (<$>) fn (Just x) = Just (fn x) (<$>) _ _ = Nothing - + instance (Show a) => Prelude.Show (Maybe a) where show (Just x) = "Just " ++ (show x) show Nothing = "Nothing" @@ -467,11 +467,11 @@ 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.Monad (Either e) where return = Right (>>=) = either (\e _ -> Left e) (\a f -> f a) - + instance Prelude.Applicative (Either e) where pure = Right (<*>) (Left e) _ = Left e @@ -480,7 +480,7 @@ instance Prelude.Functor (Either a) where (<$>) _ (Left x) = Left x (<$>) f (Right y) = Right (f y) - + instance (Show a, Show b) => Prelude.Show (Either a b) where show (Left x) = "Left " ++ (show x) show (Right y) = "Right " ++ (show y) @@ -637,10 +637,10 @@ 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 @@ -898,7 +898,7 @@ foreign import tan "function tan(n){\ \ return Math.tan(n);\ \}" :: Number -> Number - + foreign import e "var e = Math.E;" :: Number foreign import ln2 "var ln2 = Math.LN2;" :: Number foreign import ln10 "var ln10 = Math.LN10;" :: Number diff --git a/purescript.cabal b/purescript.cabal --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.4.0 +version: 0.4.1 cabal-version: >=1.8 build-type: Simple license: MIT 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 @@ -32,7 +32,7 @@ typeLiterals :: Pattern () Type String typeLiterals = mkPattern match where - match (Object row) = Just $ "{ " ++ prettyPrintType row ++ " }" + match (Object row) = Just $ "{ " ++ prettyPrintRow row ++ " }" match (TypeVar var) = Just var match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]" match ty@(TypeConstructor ctor) = Just $ show ctor @@ -41,8 +41,8 @@ match (ConstrainedType deps ty) = Just $ "(" ++ intercalate "," (map (\(pn, ty') -> show pn ++ " (" ++ prettyPrintType ty' ++ ")") deps) ++ ") => " ++ prettyPrintType ty 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 REmpty = Just "()" + match row@(RCons _ _ _) = Just $ '(' : prettyPrintRow row ++ ")" match _ = Nothing -- | 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 @@ -68,6 +68,7 @@ import qualified Data.Map as M import Data.Function (on) +import Data.Ord (comparing) instance Partial Type where unknown = TUnknown @@ -152,7 +153,7 @@ 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)) ++ "." + unifyRows' sd3 r3 sd4 r4 = throwError $ "Cannot unify (" ++ prettyPrintRow (rowFromList (sd3, r3)) ++ ") with (" ++ prettyPrintRow (rowFromList (sd4, r4)) ++ ")." -- | -- Ensure type constructors are equal after canonicalization @@ -1012,6 +1013,27 @@ Just moduleName <- checkCurrentModule <$> get _ <- subsumes' Nothing ty1 ty2 return . Just $ foldl App val (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints)) +subsumes' val (Object r1) (Object r2) = 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 + | p1 > p2 = do rest <- fresh + r1 =?= RCons p2 ty2 rest + go ((p1, ty1) : ts1) ts2 rest r2 +subsumes' val ty1 ty2@(Object _) = subsumes val ty2 ty1 subsumes' val ty1 ty2 = do ty1 =?= ty2 return val