mirror of
https://github.com/github/semantic.git
synced 2024-12-28 09:21:35 +03:00
Merge pull request #1449 from github/better-generic-show1-instances
Better generic Show1 instances
This commit is contained in:
Rob Rix
GitHub
commit
6b586f035e
@ -31,9 +31,7 @@ library
|
||||
, Data.Diff
|
||||
, Data.Error
|
||||
, Data.Functor.Both
|
||||
, Data.Functor.Classes.Eq.Generic
|
||||
, Data.Functor.Classes.Ord.Generic
|
||||
, Data.Functor.Classes.Show.Generic
|
||||
, Data.Functor.Classes.Generic
|
||||
, Data.JSON.Fields
|
||||
, Data.Language
|
||||
, Data.Mergeable
|
||||
@ -163,7 +161,7 @@ test-suite test
|
||||
main-is: Spec.hs
|
||||
other-modules: Assigning.Assignment.Spec
|
||||
, Data.Diff.Spec
|
||||
, Data.Functor.Classes.Ord.Generic.Spec
|
||||
, Data.Functor.Classes.Generic.Spec
|
||||
, Data.Functor.Listable
|
||||
, Data.Mergeable.Spec
|
||||
, Data.Source.Spec
|
||||
|
||||
@ -1,49 +0,0 @@
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
module Data.Functor.Classes.Eq.Generic
|
||||
( Eq1(..)
|
||||
, genericLiftEq
|
||||
) where
|
||||
|
||||
import Data.Functor.Classes
|
||||
import GHC.Generics
|
||||
|
||||
-- | Generically-derivable lifting of the 'Eq' class to unary type constructors.
|
||||
class GEq1 f where
|
||||
-- | Lift an equality test through the type constructor.
|
||||
--
|
||||
-- The function will usually be applied to an equality function, but the more general type ensures that the implementation uses it to compare elements of the first container with elements of the second.
|
||||
gliftEq :: (a -> b -> Bool) -> f a -> f b -> Bool
|
||||
|
||||
-- | A suitable implementation of Eq1’s liftEq for Generic1 types.
|
||||
genericLiftEq :: (Generic1 f, GEq1 (Rep1 f)) => (a -> b -> Bool) -> f a -> f b -> Bool
|
||||
genericLiftEq f a b = gliftEq f (from1 a) (from1 b)
|
||||
|
||||
|
||||
-- Generics
|
||||
|
||||
instance GEq1 U1 where
|
||||
gliftEq _ _ _ = True
|
||||
|
||||
instance GEq1 Par1 where
|
||||
gliftEq f (Par1 a) (Par1 b) = f a b
|
||||
|
||||
instance Eq c => GEq1 (K1 i c) where
|
||||
gliftEq _ (K1 a) (K1 b) = a == b
|
||||
|
||||
instance Eq1 f => GEq1 (Rec1 f) where
|
||||
gliftEq f (Rec1 a) (Rec1 b) = liftEq f a b
|
||||
|
||||
instance GEq1 f => GEq1 (M1 i c f) where
|
||||
gliftEq f (M1 a) (M1 b) = gliftEq f a b
|
||||
|
||||
instance (GEq1 f, GEq1 g) => GEq1 (f :+: g) where
|
||||
gliftEq f a b = case (a, b) of
|
||||
(L1 a, L1 b) -> gliftEq f a b
|
||||
(R1 a, R1 b) -> gliftEq f a b
|
||||
_ -> False
|
||||
|
||||
instance (GEq1 f, GEq1 g) => GEq1 (f :*: g) where
|
||||
gliftEq f (a1 :*: b1) (a2 :*: b2) = gliftEq f a1 a2 && gliftEq f b1 b2
|
||||
|
||||
instance (Eq1 f, GEq1 g) => GEq1 (f :.: g) where
|
||||
gliftEq f (Comp1 a) (Comp1 b) = liftEq (gliftEq f) a b
|
||||
182
src/Data/Functor/Classes/Generic.hs
Normal file
182
src/Data/Functor/Classes/Generic.hs
Normal file
@ -0,0 +1,182 @@
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
module Data.Functor.Classes.Generic
|
||||
( Eq1(..)
|
||||
, genericLiftEq
|
||||
, Ord1(..)
|
||||
, genericLiftCompare
|
||||
, Show1(..)
|
||||
, GShow1Options(..)
|
||||
, defaultGShow1Options
|
||||
, genericLiftShowsPrec
|
||||
, genericLiftShowsPrecWithOptions
|
||||
) where
|
||||
|
||||
import Data.Functor.Classes
|
||||
import Data.List (intersperse)
|
||||
import Data.Semigroup
|
||||
import GHC.Generics
|
||||
import Text.Show (showListWith)
|
||||
|
||||
-- | Generically-derivable lifting of the 'Eq' class to unary type constructors.
|
||||
class GEq1 f where
|
||||
-- | Lift an equality test through the type constructor.
|
||||
--
|
||||
-- The function will usually be applied to an equality function, but the more general type ensures that the implementation uses it to compare elements of the first container with elements of the second.
|
||||
gliftEq :: (a -> b -> Bool) -> f a -> f b -> Bool
|
||||
|
||||
-- | A suitable implementation of Eq1’s liftEq for Generic1 types.
|
||||
genericLiftEq :: (Generic1 f, GEq1 (Rep1 f)) => (a -> b -> Bool) -> f a -> f b -> Bool
|
||||
genericLiftEq f a b = gliftEq f (from1 a) (from1 b)
|
||||
|
||||
|
||||
-- | Generically-derivable lifting of the 'Ord' class to unary type constructors.
|
||||
class GOrd1 f where
|
||||
-- | Lift a comparison function through the type constructor.
|
||||
--
|
||||
-- The function will usually be applied to a comparison function, but the more general type ensures that the implementation uses it to compare elements of the first container with elements of the second.
|
||||
gliftCompare :: (a -> b -> Ordering) -> f a -> f b -> Ordering
|
||||
|
||||
-- | A suitable implementation of Ord1’s liftCompare for Generic1 types.
|
||||
genericLiftCompare :: (Generic1 f, GOrd1 (Rep1 f)) => (a -> b -> Ordering) -> f a -> f b -> Ordering
|
||||
genericLiftCompare f a b = gliftCompare f (from1 a) (from1 b)
|
||||
|
||||
|
||||
-- | Generically-derivable lifting of the 'Show' class to unary type constructors.
|
||||
class GShow1 f where
|
||||
-- | showsPrec function for an application of the type constructor based on showsPrec and showList functions for the argument type.
|
||||
gliftShowsPrec :: GShow1Options -> (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
|
||||
|
||||
data GShow1Options = GShow1Options { optionsUseRecordSyntax :: Bool }
|
||||
|
||||
defaultGShow1Options :: GShow1Options
|
||||
defaultGShow1Options = GShow1Options { optionsUseRecordSyntax = False }
|
||||
|
||||
class GShow1 f => GShow1Body f where
|
||||
-- | showsPrec function for the body of an application of the type constructor based on showsPrec and showList functions for the argument type.
|
||||
gliftShowsPrecBody :: GShow1Options -> Fixity -> Bool -> String -> (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
|
||||
|
||||
gliftShowsPrecAll :: GShow1Options -> Bool -> (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> [ShowS]
|
||||
gliftShowsPrecAll opts _ sp sl d a = [gliftShowsPrec opts sp sl d a]
|
||||
|
||||
-- | showList function for an application of the type constructor based on showsPrec and showList functions for the argument type. The default implementation using standard list syntax is correct for most types.
|
||||
gliftShowList :: GShow1 f => GShow1Options -> (Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS
|
||||
gliftShowList opts sp sl = showListWith (gliftShowsPrec opts sp sl 0)
|
||||
|
||||
-- | A suitable implementation of Show1’s liftShowsPrec for Generic1 types.
|
||||
genericLiftShowsPrec :: (Generic1 f, GShow1 (Rep1 f)) => (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
|
||||
genericLiftShowsPrec sp sl d = gliftShowsPrec defaultGShow1Options sp sl d . from1
|
||||
|
||||
-- | A suitable implementation of Show1’s liftShowsPrec for Generic1 types.
|
||||
genericLiftShowsPrecWithOptions :: (Generic1 f, GShow1 (Rep1 f)) => GShow1Options -> (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
|
||||
genericLiftShowsPrecWithOptions options sp sl d = gliftShowsPrec options sp sl d . from1
|
||||
|
||||
|
||||
-- Generics
|
||||
|
||||
instance GEq1 U1 where
|
||||
gliftEq _ _ _ = True
|
||||
|
||||
instance GEq1 Par1 where
|
||||
gliftEq f (Par1 a) (Par1 b) = f a b
|
||||
|
||||
instance Eq c => GEq1 (K1 i c) where
|
||||
gliftEq _ (K1 a) (K1 b) = a == b
|
||||
|
||||
instance Eq1 f => GEq1 (Rec1 f) where
|
||||
gliftEq f (Rec1 a) (Rec1 b) = liftEq f a b
|
||||
|
||||
instance GEq1 f => GEq1 (M1 i c f) where
|
||||
gliftEq f (M1 a) (M1 b) = gliftEq f a b
|
||||
|
||||
instance (GEq1 f, GEq1 g) => GEq1 (f :+: g) where
|
||||
gliftEq f a b = case (a, b) of
|
||||
(L1 a, L1 b) -> gliftEq f a b
|
||||
(R1 a, R1 b) -> gliftEq f a b
|
||||
_ -> False
|
||||
|
||||
instance (GEq1 f, GEq1 g) => GEq1 (f :*: g) where
|
||||
gliftEq f (a1 :*: b1) (a2 :*: b2) = gliftEq f a1 a2 && gliftEq f b1 b2
|
||||
|
||||
instance (Eq1 f, GEq1 g) => GEq1 (f :.: g) where
|
||||
gliftEq f (Comp1 a) (Comp1 b) = liftEq (gliftEq f) a b
|
||||
|
||||
|
||||
instance GOrd1 U1 where
|
||||
gliftCompare _ _ _ = EQ
|
||||
|
||||
instance GOrd1 Par1 where
|
||||
gliftCompare f (Par1 a) (Par1 b) = f a b
|
||||
|
||||
instance Ord c => GOrd1 (K1 i c) where
|
||||
gliftCompare _ (K1 a) (K1 b) = compare a b
|
||||
|
||||
instance Ord1 f => GOrd1 (Rec1 f) where
|
||||
gliftCompare f (Rec1 a) (Rec1 b) = liftCompare f a b
|
||||
|
||||
instance GOrd1 f => GOrd1 (M1 i c f) where
|
||||
gliftCompare f (M1 a) (M1 b) = gliftCompare f a b
|
||||
|
||||
instance (GOrd1 f, GOrd1 g) => GOrd1 (f :+: g) where
|
||||
gliftCompare f a b = case (a, b) of
|
||||
(L1 a, L1 b) -> gliftCompare f a b
|
||||
(R1 a, R1 b) -> gliftCompare f a b
|
||||
(L1 _, R1 _) -> LT
|
||||
(R1 _, L1 _) -> GT
|
||||
|
||||
instance (GOrd1 f, GOrd1 g) => GOrd1 (f :*: g) where
|
||||
gliftCompare f (a1 :*: b1) (a2 :*: b2) = gliftCompare f a1 a2 <> gliftCompare f b1 b2
|
||||
|
||||
instance (Ord1 f, GOrd1 g) => GOrd1 (f :.: g) where
|
||||
gliftCompare f (Comp1 a) (Comp1 b) = liftCompare (gliftCompare f) a b
|
||||
|
||||
|
||||
instance GShow1 U1 where
|
||||
gliftShowsPrec _ _ _ _ _ = id
|
||||
|
||||
instance GShow1 Par1 where
|
||||
gliftShowsPrec _ sp _ d (Par1 a) = sp d a
|
||||
|
||||
instance Show c => GShow1 (K1 i c) where
|
||||
gliftShowsPrec _ _ _ d (K1 a) = showsPrec d a
|
||||
|
||||
instance Show1 f => GShow1 (Rec1 f) where
|
||||
gliftShowsPrec _ sp sl d (Rec1 a) = liftShowsPrec sp sl d a
|
||||
|
||||
instance GShow1 f => GShow1 (M1 D c f) where
|
||||
gliftShowsPrec opts sp sl d (M1 a) = gliftShowsPrec opts sp sl d a
|
||||
|
||||
instance (Constructor c, GShow1Body f) => GShow1 (M1 C c f) where
|
||||
gliftShowsPrec opts sp sl d m = gliftShowsPrecBody opts (conFixity m) (conIsRecord m && optionsUseRecordSyntax opts) (conName m) sp sl d (unM1 m)
|
||||
|
||||
instance GShow1Body U1 where
|
||||
gliftShowsPrecBody _ _ _ conName _ _ _ _ = showString conName
|
||||
|
||||
instance (Selector s, GShow1 f) => GShow1Body (M1 S s f) where
|
||||
gliftShowsPrecBody opts _ conIsRecord conName sp sl d m = showParen (d > 10) $ showString conName . showChar ' ' . showBraces conIsRecord (foldr (.) id (gliftShowsPrecAll opts conIsRecord sp sl 11 m))
|
||||
|
||||
gliftShowsPrecAll opts conIsRecord sp sl d m = [ (if conIsRecord && not (null (selName m)) then showString (selName m) . showString " = " else id) . gliftShowsPrec opts sp sl (if conIsRecord then 0 else d) (unM1 m) ]
|
||||
|
||||
instance (GShow1Body f, GShow1Body g) => GShow1Body (f :*: g) where
|
||||
gliftShowsPrecBody opts conFixity conIsRecord conName sp sl d (a :*: b) = case conFixity of
|
||||
Prefix -> showParen (d > 10) $ showString conName . showChar ' ' . if conIsRecord
|
||||
then showBraces True (foldr (.) id (intersperse (showString ", ") (gliftShowsPrecAll opts conIsRecord sp sl 11 (a :*: b))))
|
||||
else foldr (.) id (intersperse (showString " ") (gliftShowsPrecAll opts conIsRecord sp sl 11 (a :*: b)))
|
||||
Infix _ prec -> showParen (d > prec) $ gliftShowsPrec opts sp sl (succ prec) a . showChar ' ' . showString conName . showChar ' ' . gliftShowsPrec opts sp sl (succ prec) b
|
||||
|
||||
gliftShowsPrecAll opts conIsRecord sp sl d (a :*: b) = gliftShowsPrecAll opts conIsRecord sp sl d a ++ gliftShowsPrecAll opts conIsRecord sp sl d b
|
||||
|
||||
instance GShow1 f => GShow1 (M1 S c f) where
|
||||
gliftShowsPrec opts sp sl d (M1 a) = gliftShowsPrec opts sp sl d a
|
||||
|
||||
instance (GShow1 f, GShow1 g) => GShow1 (f :+: g) where
|
||||
gliftShowsPrec opts sp sl d (L1 l) = gliftShowsPrec opts sp sl d l
|
||||
gliftShowsPrec opts sp sl d (R1 r) = gliftShowsPrec opts sp sl d r
|
||||
|
||||
instance (GShow1 f, GShow1 g) => GShow1 (f :*: g) where
|
||||
gliftShowsPrec opts sp sl d (a :*: b) = gliftShowsPrec opts sp sl d a . showChar ' ' . gliftShowsPrec opts sp sl d b
|
||||
|
||||
instance (Show1 f, GShow1 g) => GShow1 (f :.: g) where
|
||||
gliftShowsPrec opts sp sl d (Comp1 a) = liftShowsPrec (gliftShowsPrec opts sp sl) (gliftShowList opts sp sl) d a
|
||||
|
||||
showBraces :: Bool -> ShowS -> ShowS
|
||||
showBraces should rest = if should then showChar '{' . rest . showChar '}' else rest
|
||||
@ -1,51 +0,0 @@
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
module Data.Functor.Classes.Ord.Generic
|
||||
( Ord1(..)
|
||||
, genericLiftCompare
|
||||
) where
|
||||
|
||||
import Data.Functor.Classes
|
||||
import Data.Semigroup
|
||||
import GHC.Generics
|
||||
|
||||
-- | Generically-derivable lifting of the 'Ord' class to unary type constructors.
|
||||
class GOrd1 f where
|
||||
-- | Lift a comparison function through the type constructor.
|
||||
--
|
||||
-- The function will usually be applied to a comparison function, but the more general type ensures that the implementation uses it to compare elements of the first container with elements of the second.
|
||||
gliftCompare :: (a -> b -> Ordering) -> f a -> f b -> Ordering
|
||||
|
||||
-- | A suitable implementation of Ord1’s liftCompare for Generic1 types.
|
||||
genericLiftCompare :: (Generic1 f, GOrd1 (Rep1 f)) => (a -> b -> Ordering) -> f a -> f b -> Ordering
|
||||
genericLiftCompare f a b = gliftCompare f (from1 a) (from1 b)
|
||||
|
||||
|
||||
-- Generics
|
||||
|
||||
instance GOrd1 U1 where
|
||||
gliftCompare _ _ _ = EQ
|
||||
|
||||
instance GOrd1 Par1 where
|
||||
gliftCompare f (Par1 a) (Par1 b) = f a b
|
||||
|
||||
instance Ord c => GOrd1 (K1 i c) where
|
||||
gliftCompare _ (K1 a) (K1 b) = compare a b
|
||||
|
||||
instance Ord1 f => GOrd1 (Rec1 f) where
|
||||
gliftCompare f (Rec1 a) (Rec1 b) = liftCompare f a b
|
||||
|
||||
instance GOrd1 f => GOrd1 (M1 i c f) where
|
||||
gliftCompare f (M1 a) (M1 b) = gliftCompare f a b
|
||||
|
||||
instance (GOrd1 f, GOrd1 g) => GOrd1 (f :+: g) where
|
||||
gliftCompare f a b = case (a, b) of
|
||||
(L1 a, L1 b) -> gliftCompare f a b
|
||||
(R1 a, R1 b) -> gliftCompare f a b
|
||||
(L1 _, R1 _) -> LT
|
||||
(R1 _, L1 _) -> GT
|
||||
|
||||
instance (GOrd1 f, GOrd1 g) => GOrd1 (f :*: g) where
|
||||
gliftCompare f (a1 :*: b1) (a2 :*: b2) = gliftCompare f a1 a2 <> gliftCompare f b1 b2
|
||||
|
||||
instance (Ord1 f, GOrd1 g) => GOrd1 (f :.: g) where
|
||||
gliftCompare f (Comp1 a) (Comp1 b) = liftCompare (gliftCompare f) a b
|
||||
@ -1,61 +0,0 @@
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
module Data.Functor.Classes.Show.Generic
|
||||
( Show1(..)
|
||||
, genericLiftShowsPrec
|
||||
, genericLiftShowList
|
||||
) where
|
||||
|
||||
import Data.Functor.Classes
|
||||
import GHC.Generics
|
||||
import Text.Show
|
||||
|
||||
-- | Generically-derivable lifting of the 'Show' class to unary type constructors.
|
||||
class GShow1 f where
|
||||
-- | showsPrec function for an application of the type constructor based on showsPrec and showList functions for the argument type.
|
||||
gliftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
|
||||
|
||||
-- | showList function for an application of the type constructor based on showsPrec and showList functions for the argument type. The default implementation using standard list syntax is correct for most types.
|
||||
gliftShowList :: GShow1 f => (Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS
|
||||
gliftShowList sp sl = showListWith (gliftShowsPrec sp sl 0)
|
||||
|
||||
-- | A suitable implementation of Show1’s liftShowsPrec for Generic1 types.
|
||||
genericLiftShowsPrec :: (Generic1 f, GShow1 (Rep1 f)) => (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
|
||||
genericLiftShowsPrec sp sl d = gliftShowsPrec sp sl d . from1
|
||||
|
||||
-- | A suitable implementation of Show1’s liftShowsPrec for Generic1 types.
|
||||
genericLiftShowList :: (Generic1 f, GShow1 (Rep1 f)) => (Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS
|
||||
genericLiftShowList sp sl = gliftShowList sp sl . map from1
|
||||
|
||||
|
||||
-- Generics
|
||||
|
||||
instance GShow1 U1 where
|
||||
gliftShowsPrec _ _ _ _ = id
|
||||
|
||||
instance GShow1 Par1 where
|
||||
gliftShowsPrec sp _ d (Par1 a) = sp d a
|
||||
|
||||
instance Show c => GShow1 (K1 i c) where
|
||||
gliftShowsPrec _ _ d (K1 a) = showsPrec d a
|
||||
|
||||
instance Show1 f => GShow1 (Rec1 f) where
|
||||
gliftShowsPrec sp sl d (Rec1 a) = liftShowsPrec sp sl d a
|
||||
|
||||
instance GShow1 f => GShow1 (M1 D c f) where
|
||||
gliftShowsPrec sp sl d (M1 a) = gliftShowsPrec sp sl d a
|
||||
|
||||
instance (Constructor c, GShow1 f) => GShow1 (M1 C c f) where
|
||||
gliftShowsPrec sp sl d m = showsUnaryWith (gliftShowsPrec sp sl) (conName m) d (unM1 m)
|
||||
|
||||
instance GShow1 f => GShow1 (M1 S c f) where
|
||||
gliftShowsPrec sp sl d (M1 a) = gliftShowsPrec sp sl d a
|
||||
|
||||
instance (GShow1 f, GShow1 g) => GShow1 (f :+: g) where
|
||||
gliftShowsPrec sp sl d (L1 l) = gliftShowsPrec sp sl d l
|
||||
gliftShowsPrec sp sl d (R1 r) = gliftShowsPrec sp sl d r
|
||||
|
||||
instance (GShow1 f, GShow1 g) => GShow1 (f :*: g) where
|
||||
gliftShowsPrec sp sl d (a :*: b) = gliftShowsPrec sp sl d a . showChar ' ' . gliftShowsPrec sp sl d b
|
||||
|
||||
instance (Show1 f, GShow1 g) => GShow1 (f :.: g) where
|
||||
gliftShowsPrec sp sl d (Comp1 a) = liftShowsPrec (gliftShowsPrec sp sl) (gliftShowList sp sl) d a
|
||||
@ -12,9 +12,7 @@ import Data.Foldable (asum, toList)
|
||||
import Data.Function ((&), on)
|
||||
import Data.Ix
|
||||
import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
|
||||
import Data.Functor.Classes.Eq.Generic
|
||||
import Data.Functor.Classes.Ord.Generic
|
||||
import Data.Functor.Classes.Show.Generic
|
||||
import Data.Functor.Classes.Generic
|
||||
import Data.Mergeable
|
||||
import Data.Range
|
||||
import Data.Record
|
||||
|
||||
@ -4,9 +4,7 @@ module Data.Syntax.Comment where
|
||||
import Diffing.Algorithm
|
||||
import Data.Align.Generic
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Functor.Classes.Eq.Generic
|
||||
import Data.Functor.Classes.Ord.Generic
|
||||
import Data.Functor.Classes.Show.Generic
|
||||
import Data.Functor.Classes.Generic
|
||||
import Data.Mergeable
|
||||
import GHC.Generics
|
||||
|
||||
|
||||
@ -3,9 +3,7 @@ module Data.Syntax.Declaration where
|
||||
|
||||
import Diffing.Algorithm
|
||||
import Data.Align.Generic
|
||||
import Data.Functor.Classes.Eq.Generic
|
||||
import Data.Functor.Classes.Ord.Generic
|
||||
import Data.Functor.Classes.Show.Generic
|
||||
import Data.Functor.Classes.Generic
|
||||
import Data.Mergeable
|
||||
import GHC.Generics
|
||||
|
||||
|
||||
@ -3,9 +3,7 @@ module Data.Syntax.Expression where
|
||||
|
||||
import Diffing.Algorithm
|
||||
import Data.Align.Generic
|
||||
import Data.Functor.Classes.Eq.Generic
|
||||
import Data.Functor.Classes.Ord.Generic
|
||||
import Data.Functor.Classes.Show.Generic
|
||||
import Data.Functor.Classes.Generic
|
||||
import Data.Mergeable
|
||||
import GHC.Generics
|
||||
|
||||
|
||||
@ -4,9 +4,7 @@ module Data.Syntax.Literal where
|
||||
import Diffing.Algorithm
|
||||
import Data.Align.Generic
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Functor.Classes.Eq.Generic
|
||||
import Data.Functor.Classes.Ord.Generic
|
||||
import Data.Functor.Classes.Show.Generic
|
||||
import Data.Functor.Classes.Generic
|
||||
import Data.Mergeable
|
||||
import GHC.Generics
|
||||
import Prelude
|
||||
|
||||
@ -3,9 +3,7 @@ module Data.Syntax.Statement where
|
||||
|
||||
import Diffing.Algorithm
|
||||
import Data.Align.Generic
|
||||
import Data.Functor.Classes.Eq.Generic
|
||||
import Data.Functor.Classes.Ord.Generic
|
||||
import Data.Functor.Classes.Show.Generic
|
||||
import Data.Functor.Classes.Generic
|
||||
import Data.Mergeable
|
||||
import GHC.Generics
|
||||
|
||||
|
||||
@ -3,9 +3,7 @@ module Data.Syntax.Type where
|
||||
|
||||
import Diffing.Algorithm
|
||||
import Data.Align.Generic
|
||||
import Data.Functor.Classes.Eq.Generic
|
||||
import Data.Functor.Classes.Ord.Generic
|
||||
import Data.Functor.Classes.Show.Generic
|
||||
import Data.Functor.Classes.Generic
|
||||
import Data.Mergeable
|
||||
import GHC.Generics
|
||||
|
||||
|
||||
@ -3,9 +3,7 @@ module Language.Go.Syntax where
|
||||
|
||||
import Data.Align.Generic
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Functor.Classes.Eq.Generic
|
||||
import Data.Functor.Classes.Ord.Generic
|
||||
import Data.Functor.Classes.Show.Generic
|
||||
import Data.Functor.Classes.Generic
|
||||
import Data.Mergeable
|
||||
import Diffing.Algorithm
|
||||
import GHC.Generics
|
||||
|
||||
@ -2,9 +2,7 @@
|
||||
module Language.Go.Type where
|
||||
|
||||
import Data.Align.Generic
|
||||
import Data.Functor.Classes.Eq.Generic
|
||||
import Data.Functor.Classes.Ord.Generic
|
||||
import Data.Functor.Classes.Show.Generic
|
||||
import Data.Functor.Classes.Generic
|
||||
import Data.Mergeable
|
||||
import Diffing.Algorithm
|
||||
import GHC.Generics
|
||||
|
||||
@ -4,9 +4,7 @@ module Language.Markdown.Syntax where
|
||||
import Diffing.Algorithm
|
||||
import Data.Align.Generic
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Functor.Classes.Eq.Generic
|
||||
import Data.Functor.Classes.Ord.Generic
|
||||
import Data.Functor.Classes.Show.Generic
|
||||
import Data.Functor.Classes.Generic
|
||||
import Data.Mergeable
|
||||
import GHC.Generics
|
||||
|
||||
|
||||
@ -3,9 +3,7 @@ module Language.Python.Syntax where
|
||||
|
||||
import Diffing.Algorithm
|
||||
import Data.Align.Generic
|
||||
import Data.Functor.Classes.Eq.Generic
|
||||
import Data.Functor.Classes.Ord.Generic
|
||||
import Data.Functor.Classes.Show.Generic
|
||||
import Data.Functor.Classes.Generic
|
||||
import Data.Mergeable
|
||||
import GHC.Generics
|
||||
|
||||
|
||||
@ -4,9 +4,7 @@ module Language.TypeScript.Syntax where
|
||||
import Diffing.Algorithm
|
||||
import Data.Align.Generic
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Functor.Classes.Eq.Generic
|
||||
import Data.Functor.Classes.Ord.Generic
|
||||
import Data.Functor.Classes.Show.Generic
|
||||
import Data.Functor.Classes.Generic
|
||||
import Data.Mergeable
|
||||
import GHC.Generics
|
||||
|
||||
|
||||
@ -5,9 +5,7 @@ import Diffing.Algorithm
|
||||
import Data.Aeson (ToJSON, (.=))
|
||||
import Data.Align.Generic
|
||||
import Data.Foldable (toList)
|
||||
import Data.Functor.Classes
|
||||
import Data.Functor.Classes.Eq.Generic
|
||||
import Data.Functor.Classes.Show.Generic
|
||||
import Data.Functor.Classes.Generic
|
||||
import Data.JSON.Fields
|
||||
import Data.Mergeable
|
||||
import Data.Text (Text)
|
||||
|
||||
87
test/Data/Functor/Classes/Generic/Spec.hs
Normal file
87
test/Data/Functor/Classes/Generic/Spec.hs
Normal file
@ -0,0 +1,87 @@
|
||||
module Data.Functor.Classes.Generic.Spec where
|
||||
|
||||
import Data.Functor.Classes.Generic
|
||||
import Data.Functor.Listable
|
||||
import GHC.Generics
|
||||
import Test.Hspec
|
||||
import Test.Hspec.LeanCheck
|
||||
|
||||
spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "Eq1" $ do
|
||||
describe "genericLiftEq" $ do
|
||||
prop "equivalent to derived (==) for product types" $
|
||||
\ a b -> genericLiftEq (==) a b `shouldBe` a == (b :: Product Int)
|
||||
|
||||
prop "equivalent to derived (==) for sum types" $
|
||||
\ a b -> genericLiftEq (==) a b `shouldBe` a == (b :: Sum Int)
|
||||
|
||||
prop "equivalent to derived (==) for recursive types" $
|
||||
\ a b -> genericLiftEq (==) a b `shouldBe` a == (b :: Tree Int)
|
||||
|
||||
describe "Ord1" $ do
|
||||
describe "genericLiftCompare" $ do
|
||||
prop "equivalent to derived compare for product types" $
|
||||
\ a b -> genericLiftCompare compare a b `shouldBe` compare a (b :: Product Int)
|
||||
|
||||
prop "equivalent to derived compare for sum types" $
|
||||
\ a b -> genericLiftCompare compare a b `shouldBe` compare a (b :: Sum Int)
|
||||
|
||||
prop "equivalent to derived compare for recursive types" $
|
||||
\ a b -> genericLiftCompare compare a b `shouldBe` compare a (b :: Tree Int)
|
||||
|
||||
describe "Show1" $ do
|
||||
describe "genericLiftShowsPrec" $ do
|
||||
prop "equivalent to derived showsPrec for product types" $
|
||||
\ a -> genericLiftShowsPrec showsPrec showList 0 a "" `shouldBe` showsPrec 0 (a :: Product Int) ""
|
||||
|
||||
prop "equivalent to derived showsPrec for sum types" $
|
||||
\ a -> genericLiftShowsPrec showsPrec showList 0 a "" `shouldBe` showsPrec 0 (a :: Sum Int) ""
|
||||
|
||||
prop "equivalent to derived showsPrec for recursive types" $
|
||||
\ a -> genericLiftShowsPrec showsPrec showList 0 a "" `shouldBe` showsPrec 0 (a :: Tree Int) ""
|
||||
|
||||
prop "equivalent to derived showsPrec for record selectors" $
|
||||
\ a -> genericLiftShowsPrecWithOptions defaultGShow1Options { optionsUseRecordSyntax = True } showsPrec showList 0 a "" `shouldBe` showsPrec 0 (a :: Record Int) ""
|
||||
|
||||
prop "equivalent to derived showsPrec for infix constructors" $
|
||||
\ a -> genericLiftShowsPrec showsPrec showList 0 a "" `shouldBe` showsPrec 0 (a :: Infix Int) ""
|
||||
|
||||
|
||||
data Product a = Product a a a
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Listable a => Listable (Product a) where
|
||||
tiers = cons3 Product
|
||||
|
||||
|
||||
data Sum a = Sum1 a | Sum2 a | Sum3 a
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Listable a => Listable (Sum a) where
|
||||
tiers = cons1 Sum1 \/ cons1 Sum2 \/ cons1 Sum3
|
||||
|
||||
|
||||
data Tree a = Leaf a | Branch [Tree a]
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Listable a => Listable (Tree a) where
|
||||
tiers = cons1 Leaf \/ cons1 Branch
|
||||
|
||||
instance Eq1 Tree where liftEq = genericLiftEq
|
||||
instance Ord1 Tree where liftCompare = genericLiftCompare
|
||||
instance Show1 Tree where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
|
||||
data Record a = Record { recordSelector1 :: a, recordSelector2 :: a, recordSelector3 :: a }
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Listable a => Listable (Record a) where
|
||||
tiers = cons3 Record
|
||||
|
||||
|
||||
data Infix a = a :<>: a
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Listable a => Listable (Infix a) where
|
||||
tiers = cons2 (:<>:)
|
||||
@ -1,44 +0,0 @@
|
||||
module Data.Functor.Classes.Ord.Generic.Spec where
|
||||
|
||||
import Data.Functor.Classes.Eq.Generic
|
||||
import Data.Functor.Classes.Ord.Generic
|
||||
import Data.Functor.Listable
|
||||
import GHC.Generics
|
||||
import Test.Hspec
|
||||
import Test.Hspec.LeanCheck
|
||||
|
||||
spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "genericLiftCompare" $ do
|
||||
prop "equivalent to derived compare for product types" $
|
||||
\ a b -> genericLiftCompare compare a b `shouldBe` compare a (b :: Product Int)
|
||||
|
||||
prop "equivalent to derived compare for sum types" $
|
||||
\ a b -> genericLiftCompare compare a b `shouldBe` compare a (b :: Sum Int)
|
||||
|
||||
prop "equivalent to derived compare for recursive types" $
|
||||
\ a b -> genericLiftCompare compare a b `shouldBe` compare a (b :: Tree Int)
|
||||
|
||||
|
||||
data Product a = Product a a a
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Listable a => Listable (Product a) where
|
||||
tiers = cons3 Product
|
||||
|
||||
|
||||
data Sum a = Sum1 a | Sum2 a | Sum3 a
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Listable a => Listable (Sum a) where
|
||||
tiers = cons1 Sum1 \/ cons1 Sum2 \/ cons1 Sum3
|
||||
|
||||
|
||||
data Tree a = Leaf a | Branch [Tree a]
|
||||
deriving (Eq, Generic1, Ord, Show)
|
||||
|
||||
instance Listable a => Listable (Tree a) where
|
||||
tiers = cons1 Leaf \/ cons1 Branch
|
||||
|
||||
instance Eq1 Tree where liftEq = genericLiftEq
|
||||
instance Ord1 Tree where liftCompare = genericLiftCompare
|
||||
@ -2,7 +2,7 @@ module Main where
|
||||
|
||||
import qualified Assigning.Assignment.Spec
|
||||
import qualified Data.Diff.Spec
|
||||
import qualified Data.Functor.Classes.Ord.Generic.Spec
|
||||
import qualified Data.Functor.Classes.Generic.Spec
|
||||
import qualified Data.Mergeable.Spec
|
||||
import qualified Data.Source.Spec
|
||||
import qualified Data.Term.Spec
|
||||
@ -23,7 +23,7 @@ main = hspec $ do
|
||||
parallel $ do
|
||||
describe "Assigning.Assignment" Assigning.Assignment.Spec.spec
|
||||
describe "Data.Diff" Data.Diff.Spec.spec
|
||||
describe "Data.Functor.Classes.Ord.Generic" Data.Functor.Classes.Ord.Generic.Spec.spec
|
||||
describe "Data.Functor.Classes.Generic" Data.Functor.Classes.Generic.Spec.spec
|
||||
describe "Data.Mergeable" Data.Mergeable.Spec.spec
|
||||
describe "Data.Source" Data.Source.Spec.spec
|
||||
describe "Data.Term" Data.Term.Spec.spec
|
||||
|
||||
Loading…
Reference in New Issue
Block a user