0ca3c6a · tix · git.iko.soy

git.iko.soy/tix

Switched to using range-set-list

commit0ca3c6a5f9d9e13e60e7dbc675fa51231eb4054a authoriko <ilyakooo0@gmail.com> dateMon 1 Mar 2021, 22:54 (6 years ago) parent5039519

6 files changed+17−48

compare with master

unifiedsplit

package.yaml+1 src/Control/Monad/Freer/Fresh.hs+3−3 src/Data/Map/Extra.hs+4−5 src/Data/Range.hs−30 src/Tix/Typechecker.hs+8−9 src/Tix/Types.hs+1−1

package.yaml+1

@@ -36,6 +36,7 @@ dependencies:

3636 - unordered-containers

3737 - bytestring

3838 - prettyprinter

39+ - range-set-list

3940library:

4041 source-dirs: src

4142

src/Control/Monad/Freer/Fresh.hs+3−3

@@ -7,7 +7,7 @@ where

88import Control.Monad.Freer

99import Control.Monad.Freer.State

10−import Data.Range

10+import qualified Data.RangeSet.Map as RS

1111import Tix.Types

1212

1313data Fresh x where

@@ -29,9 +29,9 @@ runFresh =

2929 MinFreshFromNow -> get

3030 )

3131

32−registerTypeVariables :: Member Fresh r => Eff r a -> Eff r (a, Range TypeVariable)

32+registerTypeVariables :: Member Fresh r => Eff r a -> Eff r (a, RS.RSet TypeVariable)

3333registerTypeVariables m = do

3434 l <- send MinFreshFromNow

3535 a <- m

3636 r <- send MinFreshFromNow

37− return (a, Range l r)

37+ return (a, RS.singletonRange (l, pred r))

src/Data/Map/Extra.hs+4−5

@@ -5,10 +5,9 @@ where

66import qualified Data.Map as M

77import Data.Map.Strict (Map)

8−import Data.Range (Range (..))

9−import qualified Data.Range as R

8+import qualified Data.RangeSet.Map as RS

109

11−restrictKeysToRange :: Ord k => Range k -> Map k v -> Map k v

10+restrictKeysToRange :: Ord k => RS.RSet k -> Map k v -> Map k v

1211restrictKeysToRange range =

13− M.takeWhileAntitone (`R.member` range)

14− . M.dropWhileAntitone (`R.notMember` range)

12+ M.takeWhileAntitone (`RS.member` range)

13+ . M.dropWhileAntitone (`RS.notMember` range)

src/Data/Range.hsdeleted−30

@@ -1,30 +0,0 @@

1−module Data.Range

2− ( Range (Range, InfiniteRange, EmptyRange),

3− member,

4− notMember,

5− )

6−where

7−

8−-- | Left included, right excluded

9−data Range a

10− = Range' !a !a

11− | InfiniteRange

12− | EmptyRange

13−

14−instance Show a => Show (Range a) where

15− show InfiniteRange = "∞"

16− show EmptyRange = "∅"

17− show (Range' l r) = show l <> "..<" <> show r

18−

19−member :: Ord a => a -> Range a -> Bool

20−member _ InfiniteRange = True

21−member _ EmptyRange = False

22−member a (Range' l r) = a >= l && a < r

23−{-# INLINE member #-}

24−

25−notMember :: Ord a => a -> Range a -> Bool

26−notMember a r = not $ member a r

27−{-# INLINE notMember #-}

28−

29−pattern Range :: Ord a => a -> a -> Range a

30−pattern Range x y <- Range' x y where Range x y = Range' (min x y) (max x y)

src/Tix/Typechecker.hs+8−9

@@ -32,8 +32,7 @@ import Data.Map.Strict (Map)

3232import qualified Data.Map.Strict as M

3333import Data.MonoTraversable

3434import Data.Monoid

35−import Data.Range (Range (..))

36−import qualified Data.Range as R

35+import qualified Data.RangeSet.Map as RS

3736import Data.Sequence (Seq (..))

3837import Data.Sequences

3938import Data.Set (Set)

@@ -186,19 +185,19 @@ v <<- x | v `occursIn` x = tell (InfinityType x) >> return mempty

186185v <<- x = return $ Substitution $ M.singleton v x

187186

188187unify :: Constraint -> UnifyM Substitution

189−unify = unifyWithPriority EmptyRange

188+unify = unifyWithPriority RS.empty

190189

191190unifyWithPriority ::

192191 -- | The range of type variables to interpret as being lower

193192 -- priority (try to replace them if possible)

194− Range TypeVariable ->

193+ RS.RSet TypeVariable ->

195194 Constraint ->

196195 UnifyM Substitution

197196unifyWithPriority range (lhs :~ rhs) =

198197 case (lhs, rhs) of

199198 (NAtomic x, NAtomic y) | x == y -> return mempty

200199 (NTypeVariable x, NTypeVariable y) ->

201− if y `R.member` range

200+ if y `RS.member` range

202201 then x <<- NTypeVariable y

203202 else y <<- NTypeVariable x

204203 (NTypeVariable t, x) -> t <<- x

@@ -215,12 +214,12 @@ unifyWithPriority range (lhs :~ rhs) =

215214 (x, y) -> tell (CanNotUnify x y) >> return mempty

216215

217216solve :: Seq Constraint -> UnifyM Substitution

218−solve = solveWithPriority EmptyRange

217+solve = solveWithPriority RS.empty

219218

220219solveWithPriority ::

221220 -- | The range of type variables to interpret as being lower

222221 -- priority (try to replace them if possible)

223− Range TypeVariable ->

222+ RS.RSet TypeVariable ->

224223 Seq Constraint ->

225224 UnifyM Substitution

226225solveWithPriority _ Empty = return mempty

@@ -478,12 +477,12 @@ inferGeneral x = traceSubtree (showExpr x) $ do

478477 s' <- solveWithPriority range cs

479478 traceValue "substitutions_after_solving" $ prettySubstitution s'

480479 let s = subs <> s'

481− returnedS = Substitution . M.filterWithKey (\k _ -> k `R.notMember` range) . unSubstitution $ s

480+ returnedS = Substitution . M.filterWithKey (\k _ -> k `RS.notMember` range) . unSubstitution $ s

482481 traceSubtree "returned" $ do

483482 traceValue "substitutions" $ prettySubstitution returnedS

484483 -- Filter for optimization purposes

485484 subEnv returnedS

486− let retT = close (Predicate (`R.member` range) <> Predicate (`S.notMember` free returnedS)) $ sub s t

485+ let retT = close (Predicate (`RS.member` range) <> Predicate (`S.notMember` free returnedS)) $ sub s t

487486 traceValue "type" $ renderPretty retT

488487 return retT

489488

src/Tix/Types.hs+1−1

@@ -41,7 +41,7 @@ data DeBrujin = DeBrujin !Int !Int

4141 deriving stock (Show, Eq, Ord)

4242

4343newtype TypeVariable = TypeVariable Int

44− deriving newtype (Eq, Ord)

44+ deriving newtype (Eq, Ord, Enum, Bounded)

4545

4646instance Show TypeVariable where

4747 show (TypeVariable n) = "〚" <> show n <> "〛"