diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/basic-sop.cabal b/basic-sop.cabal new file mode 100644 --- /dev/null +++ b/basic-sop.cabal @@ -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 @@ + 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 , Andres Löh +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 diff --git a/src/Generics/SOP/Arbitrary.hs b/src/Generics/SOP/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/src/Generics/SOP/Arbitrary.hs @@ -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 diff --git a/src/Generics/SOP/Eq.hs b/src/Generics/SOP/Eq.hs new file mode 100644 --- /dev/null +++ b/src/Generics/SOP/Eq.hs @@ -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) diff --git a/src/Generics/SOP/NFData.hs b/src/Generics/SOP/NFData.hs new file mode 100644 --- /dev/null +++ b/src/Generics/SOP/NFData.hs @@ -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 diff --git a/src/Generics/SOP/Show.hs b/src/Generics/SOP/Show.hs new file mode 100644 --- /dev/null +++ b/src/Generics/SOP/Show.hs @@ -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 diff --git a/src/Generics/SOP/Skeleton.hs b/src/Generics/SOP/Skeleton.hs new file mode 100644 --- /dev/null +++ b/src/Generics/SOP/Skeleton.hs @@ -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