bound-simple (empty) → 0.1.0.0

raw patch · 8 files changed

+639/−0 lines, 8 filesdep +basedep +bound-simpledep +hspecsetup-changed

Dependencies added: base, bound-simple, hspec, transformers

Files

Changelog.md +3/−0
LICENSE +30/−0
README.md +53/−0
Setup.hs +2/−0
bound-simple.cabal +42/−0
src/Bound/Simple.hs +317/−0
src/Data/Functor/Classes/Generic.hs +191/−0
test/Spec.hs +1/−0

+ Changelog.md view

@@ -0,0 +1,3 @@+0.1++first version

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Marco Zocca (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Marco Zocca nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,53 @@+# bound-simple++A lightweight implementation of 'bound'. Provides much of the functionality of Bound.Scope.Simple, without the large dependency footprint.++## Example ++The function `whnf` beta-reduces a term of the untyped lambda calculus.++In the code below, we first declare a type `Exp` for terms, using the `Scope` type within the constructor for a lambda abstraction. To this we add a few instances necessary for showing and traversing the terms. The Monad instance takes care of variable substitution.+After that, abstraction and application are implemented in terms of abstract1 and instantiate1.+The `test` function declares a term `(\x . x) y` , then prints it and its reduced form.++++```haskell+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}++import Control.Monad (ap)+import Bound.Simple (Scope, Bound(..), abstract1, instantiate1)+import Data.Functor.Classes.Generic (Generically(..))++import GHC.Generics (Generic1)++infixl 9 :+data Exp a = V a | Exp a : Exp a | Lam (Scope () Exp a)+  deriving (Show, Functor, Foldable, Traversable, Generic1)+  deriving (Show1) via Generically Exp++instance Applicative Exp where pure = V; k <*> m = ap k m++instance Monad Exp where+  return = V+  V a      >>= f = f a+  (x :@ y) >>= f = (x >>= f) :@ (y >>= f)+  Lam e    >>= f = Lam (e >>>= f)++lam :: Eq a => a -> Exp a -> Exp a+lam v b = Lam (abstract1 v b)++whnf :: Exp a -> Exp a+whnf (e1 :@ e2) = case whnf e1 of+  Lam b -> whnf (instantiate1 e2 b)+  f'    -> f' :@ e2+whnf e = e++test :: IO ()+test = do+  let term = lam x (V x) :@ V y+  print term         -- Lam (Scope (V (B ()))) :@ V y+  print $ whnf term  -- V y+```

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ bound-simple.cabal view

@@ -0,0 +1,42 @@+name:                bound-simple+version:             0.1.0.0+synopsis:            A lightweight implementation of 'bound'+description:         An abstraction for representing bound variables. Most of this code has been extracted from 'bound', with the purpose of providing a mostly self-contained library for implementing embedded languages.+homepage:            https://github.com/ocramz/bound-simple+license:             BSD3+license-file:        LICENSE+author:              Marco Zocca+maintainer:          ocramz+copyright:           2013 Edward Kmett, 2021 Marco Zocca+category:            Language+build-type:          Simple+extra-source-files:  README.md+                     Changelog.md+cabal-version:       >=1.10+tested-with:         GHC == 8.10.7++library+  default-language:    Haskell2010+  ghc-options:         -Wall+  hs-source-dirs:      src+  exposed-modules:     Bound.Simple+                       Data.Functor.Classes.Generic+  build-depends:       base >= 4.7 && < 5+                     , transformers+                     -- -- DEBUG+                     -- , hspec >= 2.7.10+  other-extensions: DerivingVia++test-suite spec+  default-language:    Haskell2010+  ghc-options:         -Wall+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , bound-simple+                     , hspec++source-repository head+  type:     git+  location: https://github.com/ocramz/bound-simple

+ src/Bound/Simple.hs view

@@ -0,0 +1,317 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DerivingStrategies #-}+{-# language DeriveAnyClass #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# language CPP #-}+{-# options_ghc -Wno-unused-top-binds #-}+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2013 Edward Kmett+--                (C) 2021 Marco Zocca (ocramz)+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ocramz+-- Stability   :  experimental+-- Portability :  portable+--+-- 'Scope' is to be used inside of the definition of binders.+--+-- A lightweight implementation of 'bound'. Provides much of the functionality of Bound.Scope.Simple, without the large dependency footprint.+--+-- = Example+--+-- The 'whnf' function in this example shows how to beta-reduce a term of the untyped lambda calculus.+--+-- Note : the Show instance of Exp depends on its Show1 instance (since Exp has one type parameter), which can be derived 'Generically' thanks to DerivingVia. This works on most recent versions of GHC (>= 8.6.1).+--+-- @+-- {-# LANGUAGE DeriveFunctor #-}+-- {-# LANGUAGE DeriveFoldable #-}+-- {-# LANGUAGE DeriveTraversable #-}+--+-- import Bound.Simple (Scope, Bound(..), abstract1, instantiate1)+-- import Data.Functor.Classes.Generic (Generically(..))+-- +-- import GHC.Generics (Generic1)+--+-- infixl 9 :\@+-- data Exp a = V a | Exp a :@ Exp a | Lam (Scope () Exp a)+--   deriving (Show, Functor, Foldable, Traversable, Generic1)+--   deriving (Show1) via Generically Exp+--+-- instance Applicative Exp where pure = V; k \<*\> m = ap k m+--+-- instance Monad Exp where+--   return = V+--   V a      >>= f = f a+--   (x :\@ y) >>= f = (x >>= f) :\@ (y >>= f)+--   Lam e    >>= f = Lam (e '>>>=' f)+--+-- lam :: Eq a => a -> Exp a -> Exp a+-- lam v b = Lam ('abstract1' v b)+--+-- whnf :: Exp a -> Exp a+-- whnf (e1 \:\@ e2) = case whnf e1 of+--   Lam b -> whnf ('instantiate1' e2 b)+--   f'    -> f' :\@ e2+-- whnf e = e+--+-- main :: IO ()+-- main = do+--   let term = lam 'x' (V 'x') :\@ V 'y'+--   print term         -- Lam (Scope (V (B ()))) :\@ V 'y'+--   print $ whnf term  -- V 'y'+-- @+----------------------------------------------------------------------------+++module Bound.Simple (Bound(..)+                    , Scope, toScope, fromScope+                    , Var+                    -- * Abstraction+                    , abstract, abstract1+                    -- * Instantiation+                    , instantiate, instantiate1+                    , bindings+                    , hoistScope+                    , closed+                    , substitute+                    , substituteVar+                    -- ** Predicates+                    , isClosed+                    -- * Utils+                    , Generically(..)+                    ) where++import Control.Monad (ap, liftM)+import Control.Monad.Trans.Class (MonadTrans(..))+import Data.Functor.Classes (Show2(..), Show1(..), showsUnaryWith, showsPrec1, liftShowsPrec2, Eq2(..), Eq1(..), eq1, liftEq, liftEq2)+import GHC.Generics (Generic1)+import Data.Functor.Classes.Generic (Generically(..))++infixl 9 :@+data Exp a = V a | Exp a :@ Exp a | Lam (Scope () Exp a)+  deriving (Show, Eq, Functor,Foldable,Traversable, Generic1)+  deriving (Show1, Eq1) via Generically Exp++-- instance Applicative Exp where pure = V; (<*>) = ap++-- instance Monad Exp where+--   return = V+--   V a      >>= f = f a+--   (x :@ y) >>= f = (x >>= f) :@ (y >>= f)+--   Lam e    >>= f = Lam (e >>>= f)++-- lam :: Eq a => a -> Exp a -> Exp a+-- lam v b = Lam (abstract1 v b)++-- whnf :: Exp a -> Exp a+-- whnf (f :@ a) = case whnf f of+--   Lam b -> whnf (instantiate1 a b)+--   f'    -> f' :@ a+-- whnf e = e++-- test :: IO ()+-- test = do+--   let term = lam 'x' (V 'x') :@ V 'y'+--   print $ term+--   print $ whnf term+++data Var b a = B b -- ^ bound variables+             | F a -- ^ free variables+             deriving (Eq, Show, Functor, Foldable, Traversable)+instance Eq2 Var where+  liftEq2 f _ (B a) (B c) = f a c+  liftEq2 _ g (F b) (F d) = g b d+  liftEq2 _ _ _ _ = False+instance Eq b => Eq1 (Var b) where liftEq = liftEq2 (==)+instance Show2 Var where+  liftShowsPrec2 f _ _ _ d (B a) = showsUnaryWith f "B" d a+  liftShowsPrec2 _ _ h _ d (F a) = showsUnaryWith h "F" d a+instance Show b => Show1 (Var b) where+  liftShowsPrec = liftShowsPrec2 showsPrec showList++-- | @'Scope' b f a@ is an @f@ expression with bound variables in @b@,+-- and free variables in @a@+newtype Scope b f a = Scope { unscope :: f (Var b a) }+  deriving (Generic1)+  deriving (Show1, Eq1) via (Generically (Scope b f))++-- instance (Eq b, Eq1 f) => Eq1 (Scope b f)  where+--   liftEq f m n = liftEq (liftEq f) (unscope m) (unscope n)+-- instance (Show b, Show1 f) => Show1 (Scope b f) where+--   liftShowsPrec f g d m = showParen (d > 10) $+--     showString "Scope " . liftShowsPrec (liftShowsPrec f g) (liftShowList f g) 11 (unscope m)+instance (Eq e, Functor m, Eq1 m, Eq a) => Eq (Scope e m a) where (==) = eq1+instance (Show e, Functor m, Show1 m, Show a) => Show (Scope e m a) where showsPrec = showsPrec1++-- | @'fromScope'@ is just another name for 'unscope'+fromScope :: Scope b f a -> f (Var b a)+fromScope = unscope+{-# INLINE fromScope #-}++-- | @'toScope'@ is just another name for 'Scope'+toScope :: f (Var b a) -> Scope b f a+toScope = Scope+{-# INLINE toScope #-}++class Bound t where+  -- | Perform substitution+  --+  -- If @t@ is an instance of @MonadTrans@ and you are compiling on GHC >= 7.4, then this+  -- gets the default definition:+  --+  -- @m '>>>=' f = m '>>=' 'lift' '.' f@+  (>>>=) :: Monad f => t f a -> (a -> f c) -> t f c+#if defined(__GLASGOW_HASKELL__)+  default (>>>=) :: (MonadTrans t, Monad f, Monad (t f)) =>+                    t f a -> (a -> f c) -> t f c+  m >>>= f = m >>= lift . f+  {-# INLINE (>>>=) #-}+#endif++instance Bound (Scope b) where+  Scope m >>>= f = Scope $ m >>= \v -> case v of+    B b -> return (B b)+    F a -> liftM F (f a)+  {-# INLINE (>>>=) #-}++instance Functor f => Functor (Scope b f) where+  fmap f (Scope a) = Scope (fmap (fmap f) a)+  {-# INLINE fmap #-}++-- | @'toList'@ is provides a list (with duplicates) of the free variables+instance Foldable f => Foldable (Scope b f) where+  foldMap f (Scope a) = foldMap (foldMap f) a+  {-# INLINE foldMap #-}++instance Traversable f => Traversable (Scope b f) where+  traverse f (Scope a) = Scope <$> traverse (traverse f) a+  {-# INLINE traverse #-}++#if !MIN_VERSION_base(4,8,0)+instance (Functor f, Monad f) => Applicative (Scope b f) where+#else+instance Monad f => Applicative (Scope b f) where+#endif+  pure a = Scope (return (F a))+  {-# INLINE pure #-}+  (<*>) = ap+  {-# INLINE (<*>) #-}++-- | The monad permits substitution on free variables, while preserving+-- bound variables+instance Monad f => Monad (Scope b f) where+#if __GLASGOW_HASKELL__ < 710+  return a = Scope (return (F a))+  {-# INLINE return #-}+#endif+  Scope e >>= f = Scope $ e >>= \v -> case v of+    B b -> return (B b)+    F a -> unscope (f a)+  {-# INLINE (>>=) #-}+++-- | @'substitute' a p w@ replaces the free variable @a@ with @p@ in @w@.+--+-- >>> substitute "hello" ["goodnight","Gracie"] ["hello","!!!"]+-- ["goodnight","Gracie","!!!"]+substitute :: (Monad f, Eq a) => a -> f a -> f a -> f a+substitute a p w = w >>= \b -> if a == b then p else return b+{-# INLINE substitute #-}++-- | @'substituteVar' a b w@ replaces a free variable @a@ with another free variable @b@ in @w@.+--+-- >>> substituteVar "Alice" "Bob" ["Alice","Bob","Charlie"]+-- ["Bob","Bob","Charlie"]+substituteVar :: (Functor f, Eq a) => a -> a -> f a -> f a+substituteVar a p = fmap (\b -> if a == b then p else b)+{-# INLINE substituteVar #-}++-- | Capture some free variables in an expression to yield+-- a 'Scope' with bound variables in @b@+--+-- >>> :m + Data.List+-- >>> abstract (`elemIndex` "bar") "barry"+-- Scope [B 0,B 1,B 2,B 2,F 'y']+abstract :: Functor f => (a -> Maybe b) -> f a -> Scope b f a+abstract f e = Scope (fmap k e) where+  k y = case f y of+    Just z  -> B z+    Nothing -> F y+{-# INLINE abstract #-}++-- | Abstract over a single variable+--+-- >>> abstract1 'x' "xyz"+-- Scope [B (),F 'y',F 'z']+abstract1 :: (Functor f, Eq a) => a -> f a -> Scope () f a+abstract1 a = abstract (\b -> if a == b then Just () else Nothing)++-- | Enter a scope, instantiating all bound variables+--+-- >>> :m + Data.List+-- >>> instantiate (\x -> [toEnum (97 + x)]) $ abstract (`elemIndex` "bar") "barry"+-- "abccy"+instantiate :: Monad f => (b -> f a) -> Scope b f a -> f a+instantiate k e = unscope e >>= \v -> case v of+  B b -> k b+  F a -> return a+{-# INLINE instantiate #-}++-- | Enter a 'Scope' that binds one variable, instantiating it+--+-- >>> instantiate1 "x" $ Scope [B (),F 'y',F 'z']+-- "xyz"+instantiate1 :: Monad f => f a -> Scope n f a -> f a+instantiate1 e = instantiate (const e)+{-# INLINE instantiate1 #-}++hoistScope :: (f (Var b a) -> g (Var b a)) -> Scope b f a -> Scope b g a+hoistScope f = Scope . f . unscope+{-# INLINE hoistScope #-}++-- | Perform a change of variables on bound variables.+mapBound :: Functor f => (b -> b') -> Scope b f a -> Scope b' f a+mapBound f (Scope s) = Scope (fmap f' s) where+  f' (B b) = B (f b)+  f' (F a) = F a+{-# INLINE mapBound #-}+++-- | Return a list of occurences of the variables bound by this 'Scope'.+bindings :: Foldable f => Scope b f a -> [b]+bindings (Scope s) = foldr f [] s where+  f (B v) vs = v : vs+  f _ vs     = vs+{-# INLINE bindings #-}++-- | If a term has no free variables, you can freely change the type of+-- free variables it is parameterized on.+--+-- >>> closed [12]+-- Nothing+--+-- >>> closed ""+-- Just []+--+-- >>> :t closed ""+-- closed "" :: Maybe [b]+closed :: Traversable f => f a -> Maybe (f b)+closed = traverse (const Nothing)+{-# INLINE closed #-}++-- | A closed term has no free variables.+--+-- >>> isClosed []+-- True+--+-- >>> isClosed [1,2,3]+-- False+isClosed :: Foldable f => f a -> Bool+isClosed = all (const False)+{-# INLINE isClosed #-}

+ src/Data/Functor/Classes/Generic.hs view

@@ -0,0 +1,191 @@+{-# LANGUAGE TypeOperators, RankNTypes, UndecidableInstances, FlexibleInstances, FlexibleContexts #-}+{-# options_ghc -Wno-name-shadowing #-}+module Data.Functor.Classes.Generic+( Eq1(..)+, genericLiftEq+, Ord1(..)+, genericLiftCompare+, Show1(..)+, GShow1Options(..)+, defaultGShow1Options+, genericLiftShowsPrec+, genericLiftShowsPrecWithOptions+, Generically (..)+) where++import Data.Functor.Classes+import Data.List (intersperse)+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++newtype 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++-- | Used with the `DerivingVia` extension to provide fast derivations for+-- 'Eq1', 'Show1', and 'Ord1'.+newtype Generically f a = Generically { unGenerically :: f a }++instance (Generic1 f, GEq1 (Rep1 f)) => Eq1 (Generically f) where liftEq eq (Generically a1) (Generically a2) = genericLiftEq eq a1 a2+instance (Generic1 f, GEq1 (Rep1 f), GOrd1 (Rep1 f)) => Ord1  (Generically f) where liftCompare compare (Generically a1) (Generically a2) = genericLiftCompare compare a1 a2+instance (Generic1 f, GShow1 (Rep1 f)) => Show1 (Generically f) where liftShowsPrec d sp sl = genericLiftShowsPrec d sp sl . unGenerically

+ test/Spec.hs view

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}