From: Javier Sagredo Date: Sun, 3 May 2026 16:43:03 +0000 (+0200) Subject: demo: cover equality, family-in-context, greetings, and multi-param instance cases X-Git-Url: https://git.sagredo.dev/?a=commitdiff_plain;h=585c37ca0192fe412b94494a8a6b252cd1ee5a45;p=classgraph.git demo: cover equality, family-in-context, greetings, and multi-param instance cases --- diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..4799fb5 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +dist-newstyle +classgraph-demo.html +examples/demo/.classgraph \ No newline at end of file diff --git a/examples/demo/demo.cabal b/examples/demo/demo.cabal index 12d0ca9..eaa8c0b 100644 --- a/examples/demo/demo.cabal +++ b/examples/demo/demo.cabal @@ -17,6 +17,9 @@ library Demo.OpenFamily Demo.ClosedFamily Demo.Orphan + Demo.Greetings + Demo.Equality + Demo.MoreFamilies build-depends: base ^>=4.22 , classgraph ghc-options: -Wall diff --git a/examples/demo/src/Demo/Equality.hs b/examples/demo/src/Demo/Equality.hs new file mode 100644 index 0000000..f66a9cd --- /dev/null +++ b/examples/demo/src/Demo/Equality.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Exercises the type-equality predicate path: an instance whose +-- context contains @a ~ b@. The viewer should: +-- +-- * Render this in the side panel as @a ~ b@ (infix), not as +-- @~ a b@ (a fake class application). +-- * Surface the equality as a chip on the instance node in the +-- graph rather than as an edge to a synthetic class. +module Demo.Equality where + +import Demo.Basic (Pretty (..)) +import Demo.OpenFamily (Norm) + +-- A class indexed by two types. +class TwoSame a b where + asSame :: a -> b + +-- An instance that only fires when the two indices are the same type. +-- The constraint @a ~ b@ stays in the dictionary's theta after +-- type-checking, so the viewer sees an EqPred. +instance (a ~ b, Pretty a) => TwoSame a b where + asSame x = x + +-- An equality constraint that *also* contains a type-family application — +-- exercises both features together: @Norm a ~ Int@ keeps the family +-- mention visible while the chip renders the equality. +class NormalisesToInt a where + toInt :: a -> Int + +instance (Norm a ~ Int, Pretty a) => NormalisesToInt a where + toInt _ = 0 diff --git a/examples/demo/src/Demo/Greetings.hs b/examples/demo/src/Demo/Greetings.hs new file mode 100644 index 0000000..b5dbed8 --- /dev/null +++ b/examples/demo/src/Demo/Greetings.hs @@ -0,0 +1,19 @@ +-- | A class with eight instances so the per-instance visibility filter, +-- "Show all" / "Hide all" buttons, and substring filter input all have +-- something to chew on. +module Demo.Greetings where + +class Greeting a where + greet :: a -> String + +instance Greeting Int where greet n = "int " <> show n +instance Greeting Bool where greet True = "yes" + greet False = "no" +instance Greeting Char where greet c = ['\'', c, '\''] +instance Greeting Integer where greet n = "integer " <> show n +instance Greeting Double where greet n = "double " <> show n +instance Greeting Float where greet n = "float " <> show n +instance Greeting () where greet _ = "unit" +instance Greeting Ordering where greet o = case o of LT -> "lt" + EQ -> "eq" + GT -> "gt" diff --git a/examples/demo/src/Demo/MoreFamilies.hs b/examples/demo/src/Demo/MoreFamilies.hs new file mode 100644 index 0000000..5466511 --- /dev/null +++ b/examples/demo/src/Demo/MoreFamilies.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | A class whose /instance contexts/ (not its superclass theta) +-- reference a type-family application. The viewer's instance view +-- should attach a "via family" edge from the instance node to the +-- @Bag@ family node, plus surface every known @type instance Bag …@ +-- row underneath. +module Demo.MoreFamilies where + +import Demo.Basic (Pretty (..)) + +-- An open type family whose instances live a few lines below this +-- declaration. The viewer's family view should list both rows. +type family Bag a + +class Boxable a where + box :: a -> Bag a + +-- The context @Pretty (Bag a)@ mentions @Bag@ inside a class +-- predicate. With the new family-association feature, the instance +-- view of @Boxable@ should draw an edge to the @Bag@ family node and +-- pull in the type-instance rows. +instance Pretty (Bag a) => Boxable a where + box _ = error "demo: Boxable Bag is unimplemented" + +-- Concrete family equations. +type instance Bag Int = [Int] +type instance Bag Bool = String + +-- A second class that depends on @Bag@'s output via a constraint +-- referencing it indirectly. +class HasBaggedInfo a where + baggedInfo :: a -> String + +instance Pretty (Bag a) => HasBaggedInfo a where + baggedInfo _ = "bagged" diff --git a/examples/demo/src/Demo/MultiParam.hs b/examples/demo/src/Demo/MultiParam.hs index d04b666..2c455b6 100644 --- a/examples/demo/src/Demo/MultiParam.hs +++ b/examples/demo/src/Demo/MultiParam.hs @@ -33,3 +33,25 @@ instance Container [] where instance Pretty' Int where pretty' = show + +-- A boxed value, used below to give HasDefault some instances. Picking a +-- two-parameter datatype so the multi-param edge labelling is visible. +data Box v = Box v + +-- HasDefault instances — populates the previously empty class so the +-- multi-param positional mapping (`v`) shows up in the *instance* view as +-- well as the classes view, and Pretty' v context appears as a +-- context-edge to the Pretty' class. +instance Pretty' v => HasDefault (Box v) v where + defaultValue (Box v) = v + +instance HasDefault (Maybe Int) Int where + defaultValue (Just n) = n + defaultValue Nothing = 0 + +-- A multi-param Indexed instance; the superclass edge `Indexed c k → +-- Container c` should be visible as an edge with positional label `c`. +instance Indexed [] Int where + lookup' i xs + | i < length xs = Just (xs !! i) + | otherwise = Nothing