770351a · rowtype-yoga/purescript-native

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

Use monad-unify 0.2.2 for improved performance

commit770351a72a5c68b98f112ff6a5781f35332865a1 authorPhil Freeman <paf31@cantab.net> dateMon 14 Apr 2014, 23:54 (13 years ago) parentbf47876

6 files changed+50−13

compare with golang

unifiedsplit

purescript.cabal+5−5 src/Language/PureScript/Kinds.hs+14 src/Language/PureScript/Pretty/Kinds.hs+1−2 src/Language/PureScript/Pretty/Types.hs+2−2 src/Language/PureScript/TypeChecker/Kinds.hs+12 src/Language/PureScript/TypeChecker/Types.hs+16−4

purescript.cabal+5−5

@@ -1,5 +1,5 @@

11name: purescript

2−version: 0.4.18

2+version: 0.4.18.1

33cabal-version: >=1.8

44build-type: Custom

55license: MIT

@@ -18,11 +18,11 @@ data-files: prelude/prelude.purs

1818data-dir: ""

1919

2020library

21− build-depends: base >=4 && <5, cmdtheline -any, containers -any,

21+ build-depends: base >=4 && <5, cmdtheline -any, containers -any, unordered-containers -any,

2222 directory >= 1.2, filepath -any, mtl -any, parsec -any, syb >= 0.4.1 && < 0.5,

23− transformers -any, utf8-string -any,

24− pattern-arrows >= 0.0.2 && < 0.1,

25− monad-unify >= 0.2.1 && < 0.3,

23+ transformers -any, utf8-string -any,

24+ pattern-arrows >= 0.0.2 && < 0.1,

25+ monad-unify >= 0.2.2 && < 0.3,

2626 xdg-basedir -any, time -any

2727 if (!os(windows))

2828 build-depends: unix -any

src/Language/PureScript/Kinds.hs+14

@@ -44,3 +44,17 @@ data Kind

4444 -- Function kinds

4545 --

4646 | FunKind Kind Kind deriving (Show, Eq, Data, Typeable)

47+

48+everywhereOnKinds :: (Kind -> Kind) -> Kind -> Kind

49+everywhereOnKinds f = go

50+ where

51+ go (Row k1) = f (Row (go k1))

52+ go (FunKind k1 k2) = f (FunKind (go k1) (go k2))

53+ go other = f other

54+

55+everythingOnKinds :: (r -> r -> r) -> (Kind -> r) -> Kind -> r

56+everythingOnKinds (<>) f = go

57+ where

58+ go k@(Row k1) = f k <> go k1

59+ go k@(FunKind k1 k2) = f k <> go k1 <> go k2

60+ go other = f other

src/Language/PureScript/Pretty/Kinds.hs+1−2

@@ -21,7 +21,6 @@ import Data.Maybe (fromMaybe)

2121

2222import Control.Arrow (ArrowPlus(..))

2323import Control.PatternArrows

24−import Control.Monad.Unify

2524

2625import Language.PureScript.Kinds

2726import Language.PureScript.Pretty.Common

@@ -31,7 +30,7 @@ typeLiterals = mkPattern match

3130 where

3231 match Star = Just "*"

3332 match Bang = Just "!"

34− match (KUnknown (Unknown u)) = Just $ 'u' : show u

33+ match (KUnknown u) = Just $ 'u' : show u

3534 match _ = Nothing

3635

3736matchRow :: Pattern () Kind ((), Kind)

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

@@ -24,7 +24,6 @@ import Data.List (intercalate)

2424

2525import Control.Arrow ((<+>))

2626import Control.PatternArrows

27−import Control.Monad.Unify

2827

2928import Language.PureScript.Types

3029import Language.PureScript.Pretty.Common

@@ -37,7 +36,7 @@ typeLiterals = mkPattern match

3736 match (PrettyPrintObject row) = Just $ "{ " ++ prettyPrintRow row ++ " }"

3837 match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"

3938 match (TypeConstructor ctor) = Just $ show ctor

40− match (TUnknown (Unknown u)) = Just $ 'u' : show u

39+ match (TUnknown u) = Just $ 'u' : show u

4140 match (Skolem name s _) = Just $ name ++ show s

4241 match (ConstrainedType deps ty) = Just $ "(" ++ intercalate ", " (map (\(pn, ty') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom ty')) deps) ++ ") => " ++ prettyPrintType ty

4342 match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintTypeAtom args) ++ ">"

@@ -117,3 +116,4 @@ prettyPrintTypeAtom = fromMaybe (error "Incomplete pattern") . pattern matchType

117116--

118117prettyPrintType :: Type -> String

119118prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType () . insertPlaceholders

119+

src/Language/PureScript/TypeChecker/Kinds.hs+12

@@ -37,12 +37,23 @@ import Control.Monad.Unify

3737import Control.Applicative

3838

3939import qualified Data.Map as M

40+import qualified Data.HashMap.Strict as H

4041import Data.Monoid ((<>))

4142

4243instance Partial Kind where

4344 unknown = KUnknown

4445 isUnknown (KUnknown u) = Just u

4546 isUnknown _ = Nothing

47+ unknowns = everythingOnKinds (++) go

48+ where

49+ go (KUnknown u) = [u]

50+ go _ = []

51+ ($?) sub = everywhereOnKinds go

52+ where

53+ go t@(KUnknown u) = case H.lookup u (runSubstitution sub) of

54+ Nothing -> t

55+ Just t' -> t'

56+ go other = other

4657

4758instance Unifiable Check Kind where

4859 KUnknown u1 =?= KUnknown u2 | u1 == u2 = return ()

@@ -171,3 +182,4 @@ infer' (ConstrainedType deps ty) = do

171182infer' _ = error "Invalid argument to infer"

172183

173184

185+

src/Language/PureScript/TypeChecker/Types.hs+16−4

@@ -68,6 +68,7 @@ import Control.Applicative

6868import Control.Arrow (Arrow(..))

6969

7070import qualified Data.Map as M

71+import qualified Data.HashMap.Strict as H

7172import Data.Function (on)

7273import Data.Ord (comparing)

7374import Data.Monoid ((<>))

@@ -76,6 +77,16 @@ instance Partial Type where

7677 unknown = TUnknown

7778 isUnknown (TUnknown u) = Just u

7879 isUnknown _ = Nothing

80+ unknowns = everythingOnTypes (++) go

81+ where

82+ go (TUnknown u) = [u]

83+ go _ = []

84+ ($?) sub = everywhereOnTypes go

85+ where

86+ go t@(TUnknown u) = case H.lookup u (runSubstitution sub) of

87+ Nothing -> t

88+ Just t' -> t'

89+ go other = other

7990

8091instance Unifiable Check Type where

8192 (=?=) = unifyTypes

@@ -494,9 +505,9 @@ varIfUnknown ty =

494505 toName = (:) 't' . show

495506 ty' = everywhereOnTypes typeToVar ty

496507 typeToVar :: Type -> Type

497− typeToVar (TUnknown (Unknown u)) = TypeVar (toName u)

508+ typeToVar (TUnknown u) = TypeVar (toName u)

498509 typeToVar t = t

499− in mkForAll (sort . map (toName . runUnknown) $ unks) ty'

510+ in mkForAll (sort . map toName $ unks) ty'

500511

501512-- |

502513-- Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns

@@ -791,13 +802,13 @@ checkBinders nvals ret (CaseAlternative binders grd val : bs) = do

791802-- Generate a new skolem constant

792803--

793804newSkolemConstant :: UnifyT Type Check Int

794−newSkolemConstant = runUnknown <$> fresh'

805+newSkolemConstant = fresh'

795806

796807-- |

797808-- Generate a new skolem scope

798809--

799810newSkolemScope :: UnifyT Type Check SkolemScope

800−newSkolemScope = SkolemScope . runUnknown <$> fresh'

811+newSkolemScope = SkolemScope <$> fresh'

801812

802813-- |

803814-- Skolemize a type variable by replacing its instances with fresh skolem constants

@@ -1109,3 +1120,4 @@ subsumes' val ty1 ty2 = do

11091120

11101121

11111122

1123+