c00466d · tix · git.iko.soy

git.iko.soy/tix

optimized colsing

commitc00466df57f2b394b4b55a70f76123904ea26072 authoriko <ilyakooo0@gmail.com> dateSat 31 Oct 2020, 18:56 (6 years ago) parent4f4657e

4 files changed+67−6

compare with master

unifiedsplit

package.yaml+3 src/Data/Map/Shifted/Strict.hs+39 src/Tix/Typechecker.hs+17−6 stack.yaml+8

package.yaml+3

@@ -28,6 +28,8 @@ dependencies:

2828 - lens

2929 - data-fix

3030 - mono-traversable

31+ - acts

32+ - groups

3133library:

3234 source-dirs: src

3335

@@ -70,3 +72,4 @@ default-extensions:

7072 - PatternSynonyms

7173 - ViewPatterns

7274 - KindSignatures

75+ - MultiParamTypeClasses

src/Data/Map/Shifted/Strict.hsnew file+39

@@ -0,0 +1,39 @@

1+module Data.Map.Shifted.Strict

2+ ( ShiftedMap (..),

3+ Data.Map.Shifted.Strict.lookup,

4+ insert,

5+ shift,

6+ liftMap,

7+ unshift,

8+ )

9+where

10+

11+import Data.Act

12+import Data.Group

13+import Data.Map.Strict (Map)

14+import qualified Data.Map.Strict as M

15+

16+data ShiftedMap d k v = ShiftedMap d (Map k v)

17+ deriving stock (Eq, Ord, Show)

18+

19+instance (Act d v, Group d, Ord k) => Semigroup (ShiftedMap d k v) where

20+ (ShiftedMap d m) <> (ShiftedMap d' m') =

21+ ShiftedMap d $ m <> (act (invert d <> d') <$> m')

22+

23+instance (Monoid d, Semigroup (ShiftedMap d k v)) => Monoid (ShiftedMap d k v) where

24+ mempty = ShiftedMap mempty M.empty

25+

26+lookup :: (Ord k, Act d v) => k -> ShiftedMap d k v -> Maybe v

27+lookup k (ShiftedMap d m) = act d <$> M.lookup k m

28+

29+insert :: (Ord k, Act d v, Group d) => k -> v -> ShiftedMap d k v -> ShiftedMap d k v

30+insert k v (ShiftedMap d m) = ShiftedMap d $ M.insert k ((act . invert) d v) m

31+

32+shift :: (Semigroup d) => d -> ShiftedMap d k v -> ShiftedMap d k v

33+shift d' (ShiftedMap d m) = ShiftedMap (d <> d') m

34+

35+liftMap :: Monoid d => Map k v -> ShiftedMap d k v

36+liftMap m = ShiftedMap mempty m

37+

38+unshift :: Act d v => ShiftedMap d k v -> Map k v

39+unshift (ShiftedMap d m) = act d <$> m

src/Tix/Typechecker.hs+17−6

@@ -15,15 +15,20 @@ import Control.Monad.Freer.Internal (handleRelayS)

1515import Control.Monad.Freer.Reader

1616import Control.Monad.Freer.State

1717import Control.Monad.Freer.Writer

18+import Data.Act

1819import Data.Fix

1920import Data.Foldable

2021import Data.Functor

2122import Data.Functor.Classes

23+import Data.Group

2224import Data.List.NonEmpty (NonEmpty (..))

2325import qualified Data.List.NonEmpty as NE

26+import Data.Map.Shifted.Strict (ShiftedMap (..))

27+import qualified Data.Map.Shifted.Strict as SM

2428import Data.Map.Strict (Map)

2529import qualified Data.Map.Strict as M

2630import Data.MonoTraversable

31+import Data.Monoid

2732import Data.Range (Range (..))

2833import qualified Data.Range as R

2934import Data.Sequence (Seq (..))

@@ -174,16 +179,22 @@ isClosed (x :-> y) = isClosed x && isClosed y

174179isClosed (List x) = isClosed x

175180isClosed (NAttrSet xs) = all isClosed . M.elems $ xs

176181

182+newtype DeBrujinContext = DeBrujinContext (Sum Int)

183+ deriving newtype (Eq, Ord, Show, Semigroup, Monoid, Group, Num)

184+

185+instance Act DeBrujinContext DeBrujin where

186+ act (DeBrujinContext (Sum n)) (DeBrujin i j) = DeBrujin (i + n) j

187+

177188close :: Range TypeVariable -> NType -> NType

178189close range =

179190 run

180− . evalState @(Map TypeVariable DeBrujin) M.empty

191+ . evalState @(ShiftedMap DeBrujinContext TypeVariable DeBrujin) mempty

181192 . runReader @Int 0

182193 . evalState @Int 0

183194 . close'

184195 where

185196 -- State is the sequential number, Reader is the binding context number

186− close' :: NType -> Eff '[State Int, Reader Int, State (Map TypeVariable DeBrujin)] NType

197+ close' :: NType -> Eff '[State Int, Reader Int, State (ShiftedMap DeBrujinContext TypeVariable DeBrujin)] NType

187198 close' x@(NAtomic _) = return x

188199 close' x@(NBrujin _) = return x

189200 close' (NTypeVariable tv) | tv `R.member` range = NBrujin <$> newbrujin tv

@@ -192,18 +203,18 @@ close range =

192203 close' (NAttrSet x) = bndCtx $ NAttrSet <$> traverse close' x

193204

194205 bndCtx m = do

195− modify @(Map TypeVariable DeBrujin) (fmap (\(DeBrujin i j) -> DeBrujin (i + 1) j))

206+ modify @(ShiftedMap DeBrujinContext TypeVariable DeBrujin) (SM.shift 1)

196207 x <- local @Int (+ 1) m

197− modify @(Map TypeVariable DeBrujin) (fmap (\(DeBrujin i j) -> DeBrujin (i - 1) j))

208+ modify @(ShiftedMap DeBrujinContext TypeVariable DeBrujin) (SM.shift (-1))

198209 return x

199210 newbrujin t = do

200− get @(Map TypeVariable DeBrujin) <&> M.lookup t >>= \case

211+ get @(ShiftedMap DeBrujinContext TypeVariable DeBrujin) <&> SM.lookup t >>= \case

201212 Nothing -> do

202213 i <- ask

203214 j <- get

204215 modify @Int (+ 1)

205216 let x = DeBrujin i j

206− modify @(Map TypeVariable DeBrujin) (M.insert t x)

217+ modify @(ShiftedMap DeBrujinContext TypeVariable DeBrujin) (SM.insert t x)

207218 return x

208219 Just x -> return x

209220

stack.yaml+8

@@ -37,6 +37,14 @@ packages:

3737extra-deps:

3838 - hnix-0.10.1

3939 - prettyprinter-1.7.0

40+ - acts-0.3.1.0

41+ - finitary-2.0.0.0

42+ - groups-0.4.1.0

43+ - typelits-witnesses-0.4.0.0

44+ - dependent-sum-0.7.1.0

45+ - constraints-extras-0.3.0.2

46+

47+allow-newer: true

4048# - acme-missiles-0.3

4149# - git: https://github.com/commercialhaskell/stack.git

4250# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a