dee7ee7 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Merge pull request #1653 from purescript/sort-rows

dee7ee7Phil Freeman11 years ago

src/Language/PureScript/Errors.hs+28−8

compare with golang

unifiedsplit

@@ -21,8 +21,9 @@ module Language.PureScript.Errors where

21import Prelude ()

22import Prelude.Compat

24+import Data.Ord (comparing)

24import Data.Either (lefts, rights)

25import Data.Either (lefts, rights)

25−import Data.List (intercalate, transpose, nub, nubBy)

26+import Data.List (intercalate, transpose, nub, nubBy, sortBy)

26import Data.Function (on)

27import Data.Function (on)

27import Data.Foldable (fold)

28import Data.Foldable (fold)

@@ -32,7 +33,7 @@ import Control.Monad

32import Control.Monad.Writer

33import Control.Monad.Writer

33import Control.Monad.Error.Class (MonadError(..))

34import Control.Monad.Error.Class (MonadError(..))

34import Control.Monad.Trans.State.Lazy

35import Control.Monad.Trans.State.Lazy

35−import Control.Arrow (first)

36+import Control.Arrow (first, (&&&))

37import Language.PureScript.Crash

38import Language.PureScript.Crash

38import Language.PureScript.AST

39import Language.PureScript.AST

@@ -522,12 +523,31 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

522 <> foldMap (\expr -> [ line "Relevant expression: "

523 <> foldMap (\expr -> [ line "Relevant expression: "

523 , indent $ prettyPrintValue valueDepth expr

524 , indent $ prettyPrintValue valueDepth expr

524 ]) binding

525 ]) binding

525− renderSimpleErrorMessage (TypesDoNotUnify t1 t2)

526+ renderSimpleErrorMessage (TypesDoNotUnify u1 u2)

527+ = let (sorted1, sorted2) = sortRows u1 u2

528+

529+ sortRows :: Type -> Type -> (Type, Type)

530+ sortRows r1@RCons{} r2@RCons{} = sortRows' (rowToList r1) (rowToList r2)

531+ sortRows t1 t2 = (t1, t2)

532+

533+ -- Put the common labels last

534+ sortRows' :: ([(String, Type)], Type) -> ([(String, Type)], Type) -> (Type, Type)

535+ sortRows' (s1, r1) (s2, r2) =

536+ let common :: [(String, (Type, Type))]

537+ common = sortBy (comparing fst) $ [ (name, (t1, t2)) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]

538+

539+ sd1, sd2 :: [(String, Type)]

540+ sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]

541+ sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]

542+ in ( rowFromList (sortBy (comparing fst) sd1 ++ map (fst &&& fst . snd) common, r1)

543+ , rowFromList (sortBy (comparing fst) sd2 ++ map (fst &&& snd . snd) common, r2)

544+ )

526− = paras [ line "Could not match type"

545+ in paras [ line "Could not match type"

527− , indent $ typeAsBox t1

546+ , indent $ typeAsBox sorted1

528− , line "with type"

547+ , line "with type"

529− , indent $ typeAsBox t2

548+ , indent $ typeAsBox sorted2

530− ]

549+ ]

550+

531 renderSimpleErrorMessage (KindsDoNotUnify k1 k2) =

551 renderSimpleErrorMessage (KindsDoNotUnify k1 k2) =

532 paras [ line "Could not match kind"

552 paras [ line "Could not match kind"

533 , indent $ line $ prettyPrintKind k1

553 , indent $ line $ prettyPrintKind k1

src/Language/PureScript/Pretty/Types.hs+1−1

@@ -79,7 +79,7 @@ prettyPrintRowWith open close = uncurry listToBox . toList []

80 toList :: [(String, Type)] -> Type -> ([(String, Type)], Type)

81 toList tys (RCons name ty row) = toList ((name, ty):tys) row

82− toList tys r = (tys, r)

82+ toList tys r = (reverse tys, r)

84prettyPrintRow :: Type -> String

85prettyPrintRow = render . prettyPrintRowWith '(' ')'

src/Language/PureScript/TypeChecker/Unify.hs+1−1

@@ -163,7 +163,7 @@ unifyRows r1 r2 =

163 unifyRows' [] REmpty [] REmpty = return ()

164 unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()

165 unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return ()

166− unifyRows' sd3 r3 sd4 r4 = throwError . errorMessage $ TypesDoNotUnify (rowFromList (sd3, r3)) (rowFromList (sd4, r4))

166+ unifyRows' _ _ _ _ = throwError . errorMessage $ TypesDoNotUnify r1 r2

167

168-- |

169-- Check that two types unify