Skip to content

Commit

Permalink
Add more instances, mostly Read and Ord
Browse files Browse the repository at this point in the history
Also some helper functions, for when the functor variants of type classes aren’t
flexible enough.
  • Loading branch information
sellout committed Mar 9, 2024
1 parent 803875e commit e197bd7
Show file tree
Hide file tree
Showing 16 changed files with 747 additions and 170 deletions.
90 changes: 70 additions & 20 deletions containers/src/Yaya/Containers/Pattern/IntMap.hs
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE Safe #-}
{-# OPTIONS_GHC -Wno-orphans #-}

Expand All @@ -6,33 +7,53 @@ module Yaya.Containers.Pattern.IntMap
)
where

import "base" Control.Applicative (Alternative ((<|>)), Applicative ((<*>)), (*>))
import "base" Control.Category (Category ((.)))
import "base" Data.Bool (Bool (False, True), (&&))
import "base" Data.Eq (Eq ((==)))
import "base" Data.Foldable (Foldable)
import "base" Data.Function (($))
import "base" Data.Functor (Functor (fmap))
import "base" Data.Functor.Classes
( Eq1 (liftEq),
Eq2 (liftEq2),
Ord1 (liftCompare),
Ord2 (liftCompare2),
Show1 (liftShowsPrec),
Show2 (liftShowsPrec2),
)
import "base" Data.Functor (Functor (fmap), (<$), (<$>))
import "base" Data.Ord (Ord (compare, (<=)), Ordering (EQ, GT, LT))
import "base" Data.Semigroup ((<>))
import "base" Data.Traversable (Traversable)
import qualified "base" Data.Tuple as Tuple
import "base" GHC.Generics (Generic, Generic1)
import "base" Text.Show (Show (showList, showsPrec), showParen, showString)
import "base" GHC.Read (Read (readListPrec, readPrec), expectP, parens)
import "base" Text.ParserCombinators.ReadPrec (prec, step)
import qualified "base" Text.Read.Lex as Lex
import qualified "containers" Data.IntMap.Internal as IntMap
import "yaya" Yaya.Fold
( Projectable (project),
Recursive (cata),
Steppable (embed),
)
import "base" Prelude (Num ((+)))
#if MIN_VERSION_base(4, 18, 0)
import "base" Data.Functor.Classes
( Eq1,
Eq2 (liftEq2),
Ord2 (liftCompare2),
Ord1,
Read1 (liftReadPrec),
Read2 (liftReadPrec2),
Show1,
Show2 (liftShowsPrec2),
)
import "base" Text.Show (Show (showsPrec), showParen, showString)
#else
import "base" Data.Functor.Classes
( Eq1 (liftEq),
Eq2 (liftEq2),
Ord1 (liftCompare),
Ord2 (liftCompare2),
Read1 (liftReadPrec),
Read2 (liftReadPrec2),
Show1 (liftShowsPrec),
Show2 (liftShowsPrec2),
)
import "base" Text.Show (Show (showList, showsPrec), showParen, showString)
#endif

data IntMapF a r
= NilF
Expand All @@ -42,6 +63,8 @@ data IntMapF a r
( Eq,
Ord,
Generic,
-- | @since 0.1.1.0
Read,
Show,
Foldable,
Functor,
Expand All @@ -62,10 +85,12 @@ instance Steppable (->) (IntMap.IntMap a) (IntMapF a) where
embed (TipF key a) = IntMap.Tip key a
embed (BinF prefix mask l r) = IntMap.Bin prefix mask l r

#if MIN_VERSION_base(4, 18, 0)
instance (Eq a) => Eq1 (IntMapF a)
#else
instance (Eq a) => Eq1 (IntMapF a) where
-- TODO: Remove this once base-4.18 is the oldest supported verson, as it’s
-- the default impl.
liftEq = liftEq2 (==)
#endif

instance Eq2 IntMapF where
liftEq2 f g = Tuple.curry $ \case
Expand All @@ -75,10 +100,12 @@ instance Eq2 IntMapF where
prefix == prefix' && mask == mask' && g l l' && g r r'
(_, _) -> False

#if MIN_VERSION_base(4, 18, 0)
instance (Ord a) => Ord1 (IntMapF a)
#else
instance (Ord a) => Ord1 (IntMapF a) where
-- TODO: Remove this once base-4.18 is the oldest supported verson, as it’s
-- the default impl.
liftCompare = liftCompare2 compare
#endif

instance Ord2 IntMapF where
liftCompare2 f g = Tuple.curry $ \case
Expand All @@ -91,25 +118,48 @@ instance Ord2 IntMapF where
compare prefix prefix' <> compare mask mask' <> g l l' <> g r r'
(BinF {}, _) -> GT

-- | @since 0.1.1.0
instance (Read a) => Read1 (IntMapF a) where
liftReadPrec = liftReadPrec2 readPrec readListPrec

-- | @since 0.1.1.0
instance Read2 IntMapF where
liftReadPrec2 readPrecA _ readPrecR _ =
let appPrec = 10
in parens . prec appPrec $
NilF
<$ expectP (Lex.Ident "NilF")
<|> expectP (Lex.Ident "TipF")
*> (TipF <$> step readPrec <*> step readPrecA)
<|> expectP (Lex.Ident "BinF")
*> ( BinF
<$> step readPrec
<*> step readPrec
<*> step readPrecR
<*> step readPrecR
)

#if MIN_VERSION_base(4, 18, 0)
instance (Show a) => Show1 (IntMapF a)
#else
instance (Show a) => Show1 (IntMapF a) where
-- TODO: Remove this once base-4.18 is the oldest supported verson, as it’s
-- the default impl.
liftShowsPrec = liftShowsPrec2 showsPrec showList
#endif

instance Show2 IntMapF where
liftShowsPrec2 showsPrecA _showListA showsPrecR _showListR prec =
liftShowsPrec2 showsPrecA _ showsPrecR _ p =
let appPrec = 10
nextPrec = appPrec + 1
in \case
NilF -> showString "NilF"
TipF key a ->
showParen (nextPrec <= prec) $
showString "BipF "
showParen (nextPrec <= p) $
showString "TipF "
. showsPrec nextPrec key
. showString " "
. showsPrecA nextPrec a
BinF prefix mask l r ->
showParen (nextPrec <= prec) $
showParen (nextPrec <= p) $
showString "BinF "
. showsPrec nextPrec prefix
. showString " "
Expand Down
36 changes: 32 additions & 4 deletions containers/src/Yaya/Containers/Pattern/IntSet.hs
Original file line number Diff line number Diff line change
Expand Up @@ -6,22 +6,31 @@ module Yaya.Containers.Pattern.IntSet
)
where

import "base" Control.Applicative
( Alternative ((<|>)),
Applicative ((<*>)),
(*>),
)
import "base" Control.Category (Category ((.)))
import "base" Data.Bool (Bool (False, True), (&&))
import "base" Data.Eq (Eq ((==)))
import "base" Data.Foldable (Foldable)
import "base" Data.Function (($))
import "base" Data.Functor (Functor (fmap))
import "base" Data.Functor (Functor (fmap), (<$), (<$>))
import "base" Data.Functor.Classes
( Eq1 (liftEq),
Ord1 (liftCompare),
Read1 (liftReadPrec),
Show1 (liftShowsPrec),
)
import "base" Data.Ord (Ord (compare, (<=)), Ordering (EQ, GT, LT))
import "base" Data.Semigroup ((<>))
import "base" Data.Traversable (Traversable)
import qualified "base" Data.Tuple as Tuple
import "base" GHC.Generics (Generic, Generic1)
import "base" GHC.Read (Read (readPrec), expectP, parens)
import "base" Text.ParserCombinators.ReadPrec (prec, step)
import qualified "base" Text.Read.Lex as Lex
import "base" Text.Show (Show (showsPrec), showParen, showString)
import qualified "containers" Data.IntSet.Internal as IntSet
import "yaya" Yaya.Fold
Expand All @@ -39,6 +48,8 @@ data IntSetF r
( Eq,
Ord,
Generic,
-- | @since 0.1.1.0
Read,
Show,
Foldable,
Functor,
Expand Down Expand Up @@ -79,20 +90,37 @@ instance Ord1 IntSetF where
compare prefix prefix' <> compare mask mask' <> f l l' <> f r r'
(BinF {}, _) -> GT

-- | @since 0.1.1.0
instance Read1 IntSetF where
liftReadPrec readPrecR _ =
let appPrec = 10
in parens . prec appPrec $
NilF
<$ expectP (Lex.Ident "NilF")
<|> expectP (Lex.Ident "TipF")
*> (TipF <$> step readPrec <*> step readPrec)
<|> expectP (Lex.Ident "BinF")
*> ( BinF
<$> step readPrec
<*> step readPrec
<*> step readPrecR
<*> step readPrecR
)

instance Show1 IntSetF where
liftShowsPrec showsPrecR _showListR prec =
liftShowsPrec showsPrecR _ p =
let appPrec = 10
nextPrec = appPrec + 1
in \case
NilF -> showString "NilF"
TipF prefix bm ->
showParen (nextPrec <= prec) $
showParen (nextPrec <= p) $
showString "TipF "
. showsPrec nextPrec prefix
. showString " "
. showsPrec nextPrec bm
BinF prefix mask l r ->
showParen (nextPrec <= prec) $
showParen (nextPrec <= p) $
showString "BinF "
. showsPrec nextPrec prefix
. showString " "
Expand Down
Loading

0 comments on commit e197bd7

Please sign in to comment.