basic-sop (empty) → 0.1.0.0
raw patch · 8 files changed
+347/−0 lines, 8 filesdep +QuickCheckdep +basedep +deepseqsetup-changed
Dependencies added: QuickCheck, base, deepseq, generics-sop, pretty-show, text
Files
- LICENSE +27/−0
- Setup.hs +2/−0
- basic-sop.cabal +64/−0
- src/Generics/SOP/Arbitrary.hs +37/−0
- src/Generics/SOP/Eq.hs +34/−0
- src/Generics/SOP/NFData.hs +28/−0
- src/Generics/SOP/Show.hs +58/−0
- src/Generics/SOP/Skeleton.hs +97/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2014, Well-Typed LLP, Edsko de Vries, Andres Löh+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its 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 HOLDER 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ basic-sop.cabal view
@@ -0,0 +1,64 @@+name: basic-sop+version: 0.1.0.0+synopsis: Basic examples and functions for generics-sop+description:+ This library contains various small examples of generic functions+ written using the @<https://hackage.haskell.org/generics-sop generics-sop>@+ library.+ .+ It is a good starting point if you want to see how generic functions+ can be defined in the SOP style.+ .+license: BSD3+license-file: LICENSE+author: Edsko de Vries <edsko@well-typed.com>, Andres Löh <andres@well-typed.com>+maintainer: edsko@well-typed.com+category: Generics+build-type: Simple+cabal-version: >=1.10+tested-with: GHC == 7.6.3, GHC == 7.8.2++source-repository head+ type: git+ location: https://github.com/well-typed/basic-sop++library+ exposed-modules: Generics.SOP.Eq+ Generics.SOP.Arbitrary+ Generics.SOP.Show+ Generics.SOP.Skeleton+ Generics.SOP.NFData+ build-depends: base >= 4.6 && < 5,+ generics-sop >= 0.1 && < 0.2,+ text >= 1.1 && < 1.2,+ QuickCheck >= 2.7 && < 2.8,+ pretty-show >= 1.6 && < 1.7,+ deepseq >= 1.3 && < 1.4+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall+ default-extensions: ScopedTypeVariables+ TypeFamilies+ RankNTypes+ TypeOperators+ GADTs+ ConstraintKinds+ MultiParamTypeClasses+ TypeSynonymInstances+ FlexibleInstances+ FlexibleContexts+ DeriveFunctor+ DeriveFoldable+ DeriveTraversable+ DefaultSignatures+ KindSignatures+ DataKinds+ FunctionalDependencies+ if impl (ghc >= 7.8)+ default-extensions: AutoDeriveTypeable+ other-extensions: OverloadedStrings+ OverlappingInstances+ PolyKinds+ UndecidableInstances+ TemplateHaskell+ CPP
+ src/Generics/SOP/Arbitrary.hs view
@@ -0,0 +1,37 @@+-- | Generic generation of random test cases.+--+-- This module contains a generic version of 'arbitrary' from the+-- "Test.Quickcheck" library, using @generics-sop@.+--+module Generics.SOP.Arbitrary (+ garbitrary+ -- * Re-exports+ , Arbitrary(..)+ ) where++import Control.Monad+import Test.QuickCheck++import Generics.SOP++-- | Generic generation of random test cases.+--+-- This function is a proof-of-concept implementation of a generic+-- 'arbitrary' that can be used to instantiate the 'Arbitrary' class+-- in @QuickCheck@.+--+-- If you want to use it on a datatype @T@ for which you have a+-- 'Generics.SOP.Generic' instance, you can say:+--+-- > instance Arbitrary T where+-- > arbitrary = garbitrary+--+-- Note that currently no attempts are being made to generate arbitrary+-- values of a particular size, and it is possible that this function+-- diverges for recursive structures.+--+garbitrary :: forall a. (Generic a, All2 Arbitrary (Code a)) => Gen a+garbitrary = liftM to $ hsequence =<< elements (apInjs_POP $ hcpure p arbitrary)+ where+ p :: Proxy Arbitrary+ p = Proxy
+ src/Generics/SOP/Eq.hs view
@@ -0,0 +1,34 @@+-- | Generic equality.+--+-- This module contains a generic equality function defined using+-- @generics-sop@.+--+module Generics.SOP.Eq (geq) where++import Data.Function+import Generics.SOP++-- | Generic equality.+--+-- This function reimplements the built-in generic equality that+-- you get by using @deriving Eq@.+--+-- Assuming you have a 'Generics.SOP.Generic' instance for a+-- datatype @T@, you can use 'geq' as follows:+--+-- > instance Eq T where+-- > (==) = geq+--+geq :: (Generic a, All2 Eq (Code a)) => a -> a -> Bool+geq = go sing `on` from+ where+ go :: forall xss. (All2 Eq xss) => Sing xss -> SOP I xss -> SOP I xss -> Bool+ go SCons (SOP (Z xs)) (SOP (Z ys)) = and . hcollapse $ hcliftA2 p eq xs ys+ go SCons (SOP (S xss)) (SOP (S yss)) = go sing (SOP xss) (SOP yss)+ go _ _ _ = False++ p :: Proxy Eq+ p = Proxy++ eq :: forall (a :: *). Eq a => I a -> I a -> K Bool a+ eq (I a) (I b) = K (a == b)
+ src/Generics/SOP/NFData.hs view
@@ -0,0 +1,28 @@+-- | Generic reduction to normal form.+--+-- This module contains a generic function that reduces+-- a value to normal form, defined using @generics-sop@.+--+module Generics.SOP.NFData (grnf) where++import Control.DeepSeq++import Generics.SOP++-- | Generic reduction to normal form.+--+-- This function is a generic implementation of the+-- 'rnf' function that can be used to instantiate the+-- 'NFData' class in @deepseq@.+--+-- Assuming you have a 'Generics.SOP.Generic' instance+-- for your datatype @T@, you can use 'grnf' as follows:+--+-- > instance NFData T where+-- > rnf = grnf+--+grnf :: (Generic a, All2 NFData (Code a)) => a -> ()+grnf = rnf . hcollapse . hcliftA p (K . rnf . unI) . from++p :: Proxy NFData+p = Proxy
+ src/Generics/SOP/Show.hs view
@@ -0,0 +1,58 @@+-- | Generic show.+--+-- This module contains a generic show function defined using+-- @generics-sop@.+--+module Generics.SOP.Show (gshow) where++import Data.List (intercalate)++import Generics.SOP++-- | Generic show.+--+-- This function is a proof-of-concept implementation of a function+-- that is similar to the 'show' function you get by using+-- 'deriving Show'.+--+-- It serves as an example of an SOP-style generic function that makes+-- use of metadata. However, it does currently not handle parentheses+-- correctly, and is therefore not really usable as a replacement.+--+-- If you want to use it anyway on a datatype @T@ for which you have+-- a 'Generics.SOP.Generic' instance, you can use 'gshow' as follows:+--+-- > instance Show T where+-- > show = gshow+--+gshow :: forall a. (Generic a, HasDatatypeInfo a, All2 Show (Code a))+ => a -> String+gshow a = case datatypeInfo (Proxy :: Proxy a) of+ ADT _ _ cs -> gshow' cs (from a)+ Newtype _ _ c -> gshow' (c :* Nil) (from a)++gshow' :: (All2 Show xss, SingI xss) => NP ConstructorInfo xss -> SOP I xss -> String+gshow' cs (SOP sop) = unI . hcollapse $ hcliftA2' p goConstructor cs sop++goConstructor :: All Show xs => ConstructorInfo xs -> NP I xs -> K String xs+goConstructor (Constructor n) args =+ K $ intercalate " " (n : args')+ where+ args' :: [String]+ args' = hcollapse $ hcliftA p (K . show . unI) args++goConstructor (Record n ns) args =+ K $ n ++ " {" ++ intercalate ", " args' ++ "}"+ where+ args' :: [String]+ args' = hcollapse $ hcliftA2 p goField ns args++goConstructor (Infix n _ _) (arg1 :* arg2 :* Nil) =+ K $ show arg1 ++ " " ++ show n ++ " " ++ show arg2+goConstructor (Infix _ _ _) _ = error "inaccessible"++goField :: Show a => FieldInfo a -> I a -> K String a+goField (FieldInfo field) (I a) = K $ field ++ " = " ++ show a++p :: Proxy Show+p = Proxy
+ src/Generics/SOP/Skeleton.hs view
@@ -0,0 +1,97 @@+-- | Generic computation of a skeleton.+--+-- $skeleton+--+module Generics.SOP.Skeleton (Skeleton(..)) where++import Control.Exception+import Data.Text (Text)++import Generics.SOP++-- $skeleton+--+-- A skeleton for a record type has a defined "spine" but is undefined+-- everywhere else. For instance, a skeleton for pairs would be+--+-- > (undefined, undefined)++-- | Generic computation of a skeleton.+--+-- A skeleton for a record type has a defined "spine" but is undefined+-- everywhere else. For instance, a skeleton for pairs would be+--+-- > (undefined, undefined)+--+-- We introduce a type class for this purpose because the skeleton for nested+-- records would look like+--+-- > (undefined, (undefined, undefined))+--+-- The default instance of 'skeleton' applies to record types; for everything+-- else, use undefined (or error):+--+-- > instance Skeleton SomeRecordType -- no where clause+--+-- or+--+-- > instance Skeleton SomeNonRecordType where skeleton = undefined+--+-- This is an example of how SOP-style generic functions can+-- be used with @DefaultSignatures@.+--+-- Furthermore, metadata is used in order to produce better+-- error messages. For the undefined components of a record,+-- an error is triggered that mentions the name of the field.+--+class Skeleton a where+ default skeleton :: (Generic a, HasDatatypeInfo a, Code a ~ '[xs], All Skeleton xs) => a++ -- | Returns a skeleton.+ skeleton :: a+ skeleton = gskeleton++instance Skeleton [a] where skeleton = undefined+instance Skeleton (Maybe a) where skeleton = undefined++instance Skeleton Int where skeleton = undefined+instance Skeleton Double where skeleton = undefined+instance Skeleton Rational where skeleton = undefined+instance Skeleton Bool where skeleton = undefined+instance Skeleton Text where skeleton = undefined++{-------------------------------------------------------------------------------+ Generic instance+-------------------------------------------------------------------------------}++-- | Compute a "spine" for single constructor datatype. That is, a valid of+-- that type with a defined spine but undefined everywhere else. For record+-- types we give "error" values that mention the names of the fields.+gskeleton :: forall a xs. (Generic a, HasDatatypeInfo a, Code a ~ '[xs], All Skeleton xs) => a+gskeleton = to $ gskeleton' (datatypeInfo (Proxy :: Proxy a))++gskeleton' :: All Skeleton xs => DatatypeInfo '[xs] -> SOP I '[xs]+gskeleton' (ADT _ _ (c :* Nil)) = gskeletonFor c+gskeleton' (Newtype _ _ c) = gskeletonFor c+gskeleton' _ = error "inaccessible"++gskeletonFor :: All Skeleton xs => ConstructorInfo xs -> SOP I '[xs]+gskeletonFor (Constructor _) = SOP $ Z $ spineWithNames (hpure (K ""))+gskeletonFor (Infix _ _ _) = SOP $ Z $ spineWithNames (hpure (K ""))+gskeletonFor (Record _ fs) = SOP $ Z $ spineWithNames (hliftA fieldName fs)+ where+ fieldName :: FieldInfo a -> K String a+ fieldName (FieldInfo n) = K n++spineWithNames :: (All Skeleton xs, SingI xs) => NP (K String) xs -> NP I xs+spineWithNames = hcliftA ps aux+ where+ aux :: Skeleton a => K String a -> I a+ aux (K "") = I $ skeleton+ aux (K n) = I $ mapException (addFieldName n) skeleton++addFieldName :: FieldName -> ErrorCall -> ErrorCall+addFieldName n (ErrorCall str) = ErrorCall (n ++ ": " ++ str)++ps :: Proxy Skeleton+ps = Proxy