Skip to content

Commit 5162884

Browse files
robrixrobrix
committed
Update for ghc 8.10.7.
1 parent f3edb4b commit 5162884

File tree

10 files changed

+93
-44
lines changed

10 files changed

+93
-44
lines changed

‎isometry.cabal

+1
Original file line numberDiff line numberDiff line change
@@ -175,6 +175,7 @@ library
175175
, stm ^>= 2.5
176176
, terminal-size
177177
, text
178+
, time
178179
, transformers ^>= 0.5
179180
, vector ^>= 0.12
180181

‎src/Data/Bin/Bintree.hs

+8-4
Original file line numberDiff line numberDiff line change
@@ -44,10 +44,14 @@ instance Foldable (Bintree s) where
4444
deriving instance Functor (Bintree s)
4545
deriving instance Traversable (Bintree s)
4646

47-
instance FoldableWithIndex (Index s) (Bintree s) where
47+
instance FoldableWithIndex (Index 'Z) (Bintree 'Z) where
4848
ifoldMap f = \case
4949
E -> mempty
5050
L a -> f il a
51+
52+
instance (FoldableWithIndex (Index s) (Bintree s), Place s) => FoldableWithIndex (Index ('S s)) (Bintree ('S s)) where
53+
ifoldMap f = \case
54+
E -> mempty
5155
B _ l r
5256
-> go B0 l <> go B1 r
5357
where
@@ -61,7 +65,7 @@ instance SparseUnfoldableWithIndex Bit (Index 'Z) (Bintree 'Z) where
6165
iunfoldSparse _ leaf = L (leaf il)
6266
{-# INLINABLE iunfoldSparse #-}
6367

64-
instance SparseUnfoldableWithIndex Bit (Index s) (Bintree s) => SparseUnfoldableWithIndex Bit (Index ('S s)) (Bintree ('S s)) where
68+
instance (SparseUnfoldableWithIndex Bit (Index s) (Bintree s), Place s) => SparseUnfoldableWithIndex Bit (Index ('S s)) (Bintree ('S s)) where
6569
iunfoldSparseM branch leaf = b <$> go B0 <*> go B1
6670
where
6771
go i = branch i >>= \ b -> if b then iunfoldSparseM branch (leaf . ib i) else pure E
@@ -81,8 +85,8 @@ instance Applicative (Bintree 'Z) where
8185
instance Applicative (Bintree s) => Applicative (Bintree ('S s)) where
8286
pure a = b (pure a) (pure a)
8387

84-
E <*> _ = E
85-
_ <*> E = E
88+
E <*> _ = E
89+
_ <*> E = E
8690
B _ f1 f2 <*> B _ a1 a2 = b (f1 <*> a1) (f2 <*> a2)
8791

8892
b :: Bintree s a -> Bintree s a -> Bintree ('S s) a

‎src/Data/Bin/Index.hs

+7-8
Original file line numberDiff line numberDiff line change
@@ -24,29 +24,28 @@ import Data.Coerce
2424
import Data.Functor.Classes (showsUnaryWith)
2525
import Data.Nat
2626
import Data.Word
27-
import GHC.TypeLits
2827
import Numeric (showIntAtBase)
2928

3029
type role Index representational
3130

3231
newtype Index (i :: N) = Index { getIndex :: Word32 }
3332
deriving (Eq, Ord)
3433

35-
instance KnownNat (Place i) => Bounded (Index i) where
34+
instance Place i => Bounded (Index i) where
3635
minBound = Index 0
3736
{-# INLINABLE minBound #-}
3837
maxBound = let i = Index (bit (place i) - 1) in i
3938
{-# INLINABLE maxBound #-}
4039

41-
instance KnownNat (Place i) => Enum (Index i) where
40+
instance Place i => Enum (Index i) where
4241
toEnum i | i' <- fromIntegral i
4342
, i' <= getIndex (maxBound :: Index i) = Index i'
4443
| otherwise = error "Data.Bin.Index.Index.toEnum: bad argument"
4544
{-# INLINABLE toEnum #-}
4645
fromEnum = fromIntegral . getIndex
4746
{-# INLINABLE fromEnum #-}
4847

49-
instance KnownNat (Place i) => Bits (Index i) where
48+
instance Place i => Bits (Index i) where
5049
(.&.) = coerce ((.&.) :: Word32 -> Word32 -> Word32)
5150
{-# INLINABLE (.&.) #-}
5251
(.|.) = coerce ((.|.) :: Word32 -> Word32 -> Word32)
@@ -85,7 +84,7 @@ instance KnownNat (Place i) => Bits (Index i) where
8584
in Index (shift (getIndex i) p' .|. shift (getIndex i) (-(bits - p'))) .&. maxBound
8685
{-# INLINABLE rotate #-}
8786

88-
instance KnownNat (Place i) => FiniteBits (Index i) where
87+
instance Place i => FiniteBits (Index i) where
8988
finiteBitSize = place
9089
{-# INLINABLE finiteBitSize #-}
9190

@@ -97,18 +96,18 @@ il :: Index 'Z
9796
il = Index 0
9897
{-# INLINABLE il #-}
9998

100-
ib :: forall s . KnownNat (Place s) => Bit -> Index s -> Index ('S s)
99+
ib :: Place s => Bit -> Index s -> Index ('S s)
101100
ib B0 i = Index (getIndex i)
102101
ib B1 i = Index (setBit (getIndex i) (place i))
103102
{-# INLINABLE ib #-}
104103

105-
i0, i1 :: KnownNat (Place s) => Index s -> Index ('S s)
104+
i0, i1 :: Place s => Index s -> Index ('S s)
106105
i0 = ib B0
107106
{-# INLINABLE i0 #-}
108107
i1 = ib B1
109108
{-# INLINABLE i1 #-}
110109

111-
decompose :: KnownNat (Place i) => Index ('S i) -> (Bit, Index i)
110+
decompose :: Place i => Index ('S i) -> (Bit, Index i)
112111
decompose i = (toBit (testBit (getIndex i) p), i')
113112
where
114113
p = place i'

‎src/Data/Bin/Octree.hs

+4-5
Original file line numberDiff line numberDiff line change
@@ -28,7 +28,6 @@ import Foreign.Marshal.Array.Lift
2828
import Foreign.Ptr
2929
import Foreign.Storable
3030
import GHC.Exts
31-
import GHC.TypeLits
3231
import Linear.V3
3332

3433
data Octree s a where
@@ -57,8 +56,8 @@ instance Foldable (Octree s) where
5756
where
5857
go :: b -> Octree s' a -> b
5958
go z = \case
60-
E -> z
61-
L a -> f a z
59+
E -> z
60+
L a -> f a z
6261
B _ lbf rbf ltf rtf lbn rbn ltn rtn -> go (go (go (go (go (go (go (go z rtn) ltn) rbn) lbn) rtf) ltf) rbf) lbf
6362
{-# INLINE foldr #-}
6463

@@ -77,7 +76,7 @@ instance FoldableWithIndex (V3 (Index 'Z)) (Octree 'Z) where
7776
L a -> f (pure il) a
7877
{-# INLINE ifoldMap #-}
7978

80-
instance (FoldableWithIndex (V3 (Index s)) (Octree s), KnownNat (Place s)) => FoldableWithIndex (V3 (Index ('S s))) (Octree ('S s)) where
79+
instance (FoldableWithIndex (V3 (Index s)) (Octree s), Place s) => FoldableWithIndex (V3 (Index ('S s))) (Octree ('S s)) where
8180
ifoldMap f = \case
8281
E -> mempty
8382
B _ lbf rbf ltf rtf lbn rbn ltn rtn
@@ -96,7 +95,7 @@ instance SparseUnfoldableWithIndex (V3 Bit) (V3 (Index 'Z)) (Octree 'Z) where
9695
iunfoldSparse _ leaf = L (leaf (pure il))
9796
{-# INLINE iunfoldSparse #-}
9897

99-
instance (SparseUnfoldableWithIndex (V3 Bit) (V3 (Index s)) (Octree s), KnownNat (Place s)) => SparseUnfoldableWithIndex (V3 Bit) (V3 (Index ('S s))) (Octree ('S s)) where
98+
instance (SparseUnfoldableWithIndex (V3 Bit) (V3 (Index s)) (Octree s), Place s) => SparseUnfoldableWithIndex (V3 Bit) (V3 (Index ('S s))) (Octree ('S s)) where
10099
iunfoldSparseM branch leaf = b
101100
<$> go (V3 B0 B0 B0) <*> go (V3 B1 B0 B0)
102101
<*> go (V3 B0 B1 B0) <*> go (V3 B1 B1 B0)

‎src/Data/Bin/Quadtree.hs

+15-10
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,7 @@ module Data.Bin.Quadtree
1212
( Quadtree(..)
1313
) where
1414

15+
import Control.Applicative (liftA2)
1516
import Control.Lens.Indexed
1617
import Data.Bin.Bit
1718
import Data.Bin.Index
@@ -32,8 +33,8 @@ instance Foldable (Quadtree s) where
3233
where
3334
go :: Quadtree s' a -> m
3435
go = \case
35-
E -> mempty
36-
L a -> f a
36+
E -> mempty
37+
L a -> f a
3738
B _ lb rb lt rt -> go lb <> go rb <> go lt <> go rt
3839
{-# INLINABLE foldMap #-}
3940

@@ -46,10 +47,14 @@ instance Foldable (Quadtree s) where
4647
deriving instance Functor (Quadtree s)
4748
deriving instance Traversable (Quadtree s)
4849

49-
instance FoldableWithIndex (V2 (Index s)) (Quadtree s) where
50+
instance FoldableWithIndex (V2 (Index 'Z)) (Quadtree 'Z) where
51+
ifoldMap f = \case
52+
E -> mempty
53+
L a -> f (pure il) a
54+
55+
instance (FoldableWithIndex (V2 (Index s)) (Quadtree s), Place s) => FoldableWithIndex (V2 (Index ('S s))) (Quadtree ('S s)) where
5056
ifoldMap f = \case
5157
E -> mempty
52-
L a -> f (pure il) a
5358
B _ lb rb lt rt
5459
-> go (V2 B0 B0) lb <> go (V2 B1 B0) rb
5560
<> go (V2 B0 B1) lt <> go (V2 B1 B1) rt
@@ -64,28 +69,28 @@ instance SparseUnfoldableWithIndex (V2 Bit) (V2 (Index 'Z)) (Quadtree 'Z) where
6469
iunfoldSparse _ leaf = L (leaf (pure il))
6570
{-# INLINABLE iunfoldSparse #-}
6671

67-
instance SparseUnfoldableWithIndex (V2 Bit) (V2 (Index s)) (Quadtree s) => SparseUnfoldableWithIndex (V2 Bit) (V2 (Index ('S s))) (Quadtree ('S s)) where
72+
instance (SparseUnfoldableWithIndex (V2 Bit) (V2 (Index s)) (Quadtree s), Place s) => SparseUnfoldableWithIndex (V2 Bit) (V2 (Index ('S s))) (Quadtree ('S s)) where
6873
iunfoldSparseM branch leaf = b <$> go (V2 B0 B0) <*> go (V2 B1 B0) <*> go (V2 B0 B1) <*> go (V2 B1 B1)
6974
where
7075
go i = branch i >>= \ b -> if b then iunfoldSparseM branch (leaf . (ib <$> i <*>)) else pure E
7176
{-# INLINABLE iunfoldSparseM #-}
7277

7378
iunfoldSparse branch leaf = b (go (V2 B0 B0)) (go (V2 B1 B0)) (go (V2 B0 B1)) (go (V2 B1 B1))
7479
where
75-
go i = if branch i then iunfoldSparse branch (leaf . (ib <$> i <*>)) else E
80+
go i = if branch i then iunfoldSparse branch (leaf . liftA2 ib i) else E
7681
{-# INLINABLE iunfoldSparse #-}
7782

7883
instance Applicative (Quadtree 'Z) where
7984
pure = L
8085

81-
E <*> _ = E
82-
L f <*> a = fmap f a
86+
E <*> _ = E
87+
L f <*> a = fmap f a
8388

8489
instance Applicative (Quadtree s) => Applicative (Quadtree ('S s)) where
8590
pure a = b (pure a) (pure a) (pure a) (pure a)
8691

87-
E <*> _ = E
88-
_ <*> E = E
92+
E <*> _ = E
93+
_ <*> E = E
8994
B _ f1 f2 f3 f4 <*> B _ a1 a2 a3 a4 = b (f1 <*> a1) (f2 <*> a2) (f3 <*> a3) (f4 <*> a4)
9095

9196
b :: Quadtree s a -> Quadtree s a -> Quadtree s a -> Quadtree s a -> Quadtree ('S s) a

‎src/Data/Bin/Shape.hs

+19-10
Original file line numberDiff line numberDiff line change
@@ -56,14 +56,23 @@ size :: forall s t a . KnownNat (Size s) => t s a -> Int
5656
size _ = fromIntegral (natVal (Proxy @(Size s)))
5757

5858

59-
type family Place (b :: N) :: Nat where
60-
Place 'Z = 0
61-
Place ('S s) = 1 + Place s
59+
class Place (s :: N) where
60+
place :: i s -> Int
6261

63-
-- | Produce the place of the bit for a given shape; equivalently, the power of two that the shape represents.
64-
--
65-
-- @
66-
-- size i = 2^place i
67-
-- @
68-
place :: forall s i . KnownNat (Place s) => i s -> Int
69-
place _ = fromIntegral (natVal (Proxy @(Place s)))
62+
instance Place 'Z where
63+
place _ = 0
64+
65+
instance Place n => Place ('S n) where
66+
place _ = 1 + place (Proxy @n)
67+
68+
-- type family Place (b :: N) :: Nat where
69+
-- Place 'Z = 0
70+
-- Place ('S s) = 1 + Place s
71+
72+
-- -- | Produce the place of the bit for a given shape; equivalently, the power of two that the shape represents.
73+
-- --
74+
-- -- @
75+
-- -- size i = 2^place i
76+
-- -- @
77+
-- place :: forall s i . KnownNat (Place s) => i s -> Int
78+
-- place _ = fromIntegral (natVal (Proxy @(Place s)))

‎src/Isometry/Frame.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -15,7 +15,6 @@ import Control.Effect.Labelled
1515
import Control.Effect.Lens (use)
1616
import Control.Effect.Lift
1717
import Control.Effect.Profile
18-
import Control.Effect.Time.System
1918
import Control.Effect.Trace
2019
import Data.Bin.Index (toInt)
2120
import Data.Bin.Shape as Shape
@@ -79,6 +78,7 @@ frame
7978
, Has (Lift IO) sig m
8079
, Has Profile sig m
8180
, Has (Reader Axis.Drawable) sig m
81+
, Has (Reader Epoch) sig m
8282
, Has (Reader Voxel.Drawable) sig m
8383
-- , Has (Reader UI) sig m
8484
, Has (Reader Window.Window) sig m

‎src/Isometry/Game.hs

+2-2
Original file line numberDiff line numberDiff line change
@@ -21,7 +21,6 @@ import qualified Control.Carrier.State.STM.TVar as TVar
2121
import Control.Effect.Lens.Exts as Lens
2222
import Control.Effect.Lift
2323
import Control.Effect.Thread
24-
import Control.Effect.Time.System as System
2524
import Control.Effect.Trace
2625
import Control.Exception.Lift
2726
import Control.Lens ((^.))
@@ -77,8 +76,9 @@ game
7776
:: ( Has Check sig m
7877
, Has (Lift IO) sig m
7978
, Has Profile sig m
79+
, Has (Reader Epoch) sig m
8080
, HasLabelled Thread (Thread id) sig m
81-
, Has (System.Time Instant) sig m
81+
, Has (Isometry.Time.Time Instant) sig m
8282
, Has Trace sig m
8383
)
8484
=> m ()

‎src/Isometry/Main.hs

+6-2
Original file line numberDiff line numberDiff line change
@@ -13,6 +13,7 @@ module Isometry.Main
1313
import Control.Algebra
1414
import qualified Control.Carrier.Profile.Identity as NoProfile
1515
import qualified Control.Carrier.Profile.Tree as Profile
16+
import Control.Carrier.Reader
1617
import Control.Carrier.Thread.IO
1718
import Control.Carrier.Time.System
1819
import qualified Control.Carrier.Trace.Ignoring as NoTrace
@@ -24,16 +25,19 @@ import Control.Monad.Fix
2425
import Control.Monad.IO.Class
2526
import Data.Flag
2627
import Data.Kind (Constraint, Type)
27-
import qualified GL.Carrier.Check.Identity as NoCheck
2828
import qualified GL.Carrier.Check.IO as Check
29+
import qualified GL.Carrier.Check.Identity as NoCheck
2930
import GL.Effect.Check
3031
import qualified Isometry.CLI as CLI
3132
import Isometry.Game
33+
import Isometry.Time
3234

3335
main :: IO ()
3436
main = do
3537
options <- CLI.execParser CLI.argumentsParser
36-
runThread (runTime (runCheck (CLI.check options) (runProfile (CLI.profile options) (runTrace (CLI.trace options) game))))
38+
runThread (runTime (do
39+
epoch <- now
40+
runReader (Epoch epoch) (runCheck (CLI.check options) (runProfile (CLI.profile options) (runTrace (CLI.trace options) game)))))
3741

3842
runProfile
3943
:: ( Has (Lift IO) sig m

‎src/Isometry/Time.hs

+30-2
Original file line numberDiff line numberDiff line change
@@ -1,16 +1,25 @@
11
module Isometry.Time
2-
( Instant(..)
2+
( Time(..)
3+
, Instant(..)
34
, Duration(..)
5+
, Epoch(..)
46
, now
57
, since
68
, timed
9+
, sinceEpoch
710
) where
811

12+
import Control.Carrier.Time.System as System
13+
import Control.Effect.Reader
914
import Control.Effect.State
10-
import Control.Effect.Time.System as System
15+
import Data.Fixed
16+
import Data.Time.Clock.System
17+
18+
newtype Epoch = Epoch { getEpoch :: System.Instant }
1119

1220
timed
1321
:: ( Has (System.Time Instant) sig m
22+
, Has (Reader Epoch) sig m
1423
, Has (State Duration) sig m
1524
)
1625
=> m a
@@ -22,3 +31,22 @@ timed m = do
2231
put =<< sinceEpoch
2332
pure a
2433
{-# INLINE timed #-}
34+
35+
sinceEpoch
36+
:: ( Has (Reader Epoch) sig m
37+
, Has (System.Time Instant) sig m
38+
)
39+
=> m System.Duration
40+
sinceEpoch = do
41+
now <- now
42+
epoch <- asks getEpoch
43+
let d = sinceInstant epoch now
44+
d `seq` pure d
45+
{-# INLINE sinceEpoch #-}
46+
47+
eraFrom :: Has (Reader Epoch) sig m => Instant -> m a -> m a
48+
eraFrom = local . const . Epoch
49+
50+
sinceInstant :: Instant -> Instant -> Duration
51+
sinceInstant (Instant (MkSystemTime bs bns)) (Instant (MkSystemTime as ans)) = Duration (realToFrac (as - bs) + MkFixed (fromIntegral ans - fromIntegral bns))
52+
{-# INLINABLE sinceInstant #-}

0 commit comments

Comments
 (0)