packages feed

generics-eot (empty) → 0.1

raw patch · 22 files changed

+1678/−0 lines, 22 filesdep +QuickCheckdep +basedep +directorysetup-changed

Dependencies added: QuickCheck, base, directory, doctest, filepath, hspec, interpolate, mockery, shake

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Sönke Hahn++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 Sönke Hahn 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,7 @@+`generics-eot` is a library for datatype generic programming that tries to be+very simple to understand and use. It's heavily inspired by the awesome+`generics-sop` package (http://hackage.haskell.org/package/generics-sop).++There's documentation in the source code, there's a tutorial in+`Generics.Eot.Tutorial` and there's also some examples in `examples` (and+descriptive tests for them in `test/Examples`).
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ examples/Catamorphisms.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module Catamorphisms where++import           Generics.Eot++catamorphism :: (HasEot a, Cata (Eot a) dest) =>+  a -> Proxy dest -> Typ (Eot a) dest+catamorphism a proxy = cata (toEot a) proxy++class Cata eot dest where+  type Typ eot dest :: *+  cata :: eot -> Proxy dest -> Typ eot dest+  cataConst :: Proxy eot -> dest -> Typ eot dest++instance (Cata rest dest, Cons fields dest) =>+  Cata (Either fields rest) dest where++  type Typ (Either fields rest) dest =+    ConsFunc fields dest -> Typ rest dest+  cata (Left fields) Proxy consFunc =+    cataConst (Proxy :: Proxy rest) $+    (eotConsFunc consFunc fields :: dest)+  cata (Right rest) proxy _ =+    cata rest proxy+  cataConst :: Proxy (Either fields rest) -> dest -> Typ (Either fields rest) dest+  cataConst Proxy dest = const $ cataConst (Proxy :: Proxy rest) dest++instance Cata Void dest where+  type Typ Void dest = dest+  cata :: Void -> Proxy dest -> dest+  cata void = seq void (error "impossible")+  cataConst Proxy = id++class Cons fields dest where+  type ConsFunc fields dest :: *+  eotConsFunc :: ConsFunc fields dest -> fields -> dest++instance Cons () dest where+  type ConsFunc () dest = dest+  eotConsFunc :: dest -> () -> dest+  eotConsFunc dest () = dest++instance Cons r dest => Cons (a, r) dest where+  type ConsFunc (a, r) dest = a -> ConsFunc r dest+  eotConsFunc :: (a -> ConsFunc r dest) -> (a, r) -> dest+  eotConsFunc consFunc (a, r) =+    eotConsFunc (consFunc a) r
+ examples/Docs.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}++module Docs (docs, HasSample(..)) where++import           Data.String.Interpolate+import           Data.Typeable+import           Generics.Eot++docs :: forall a . (HasEot a, GDocs Datatype (Eot a)) => Proxy a -> String+docs Proxy = unlines $ gDocs+  (datatype (Proxy :: Proxy a))+  (Proxy :: Proxy (Eot a))++class GDocs meta eot where+  gDocs :: meta -> Proxy eot -> [String]++-- * datatype++instance GDocs (Int, [Constructor]) x => GDocs Datatype x where+  gDocs (Datatype name constructors) proxy =+    [i|Datatype #{name} has #{length constructors} constructors:|] :+    "" :+    gDocs (1 :: Int, constructors) proxy++-- * constructors++instance (GDocs (Int, Constructor) c, GDocs (Int, [Constructor]) cs) =>+  GDocs (Int, [Constructor]) (Either c cs) where+    gDocs (i, (c : cs)) Proxy =+      gDocs (i, c) (Proxy :: Proxy c) +++      gDocs (succ i, cs) (Proxy :: Proxy cs)+    gDocs (_, []) Proxy = error "impossible"++instance GDocs (Int, [Constructor]) Void where+  gDocs _ Proxy = []++instance GDocs Fields fields => GDocs (Int, Constructor) fields where+  gDocs (n, Constructor name fields) Proxy = case fields of+    NoFields ->+      [[i|#{n}. Constructor #{show name} with no fields|]]+    _ ->+      [i|#{n}. Constructor #{show name} with the following fields:|] :+      gDocs fields (Proxy :: Proxy fields)++-- * fields++instance GDocs Fields () where+  gDocs _ Proxy = []++instance (Typeable f, HasSample f, Show f, GDocs Fields fs) =>+  GDocs Fields (f, fs) where+    gDocs fields Proxy = case fields of+      Selectors (name : names) ->+        [i|  - #{name} :: #{typeRep f} (example: #{show (sample :: f)})|] :+        gDocs (Selectors names) fs+      Selectors [] -> error "impossible"+      NoSelectors n ->+        [i|  - #{typeRep f} (example: #{show (sample :: f)})|] :+        gDocs (NoSelectors (pred n)) fs+      NoFields -> []+      where+        f = Proxy :: Proxy f+        fs = Proxy :: Proxy fs++-- * HasSample class++class HasSample a where+  sample :: a
+ examples/MinBound.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE FlexibleContexts #-}++module MinBound (minBoundG) where++import           Generics.Eot++minBoundG :: (HasEot a, GMinBound (Eot a)) => a+minBoundG = fromEot gMinBound++class GMinBound a where+  gMinBound :: a++instance GMinBound a => GMinBound (Either a x) where+  gMinBound = Left gMinBound++instance (Bounded f, GMinBound fs) =>+  GMinBound (f, fs) where+    gMinBound = (minBound, gMinBound)++instance GMinBound () where+  gMinBound = ()
+ examples/ToString.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module ToString (ToString(..)) where++import           Data.List+import           Generics.Eot++class ToString a where+  toString :: a -> String+  default toString :: (HasEot a, ToStringG (Eot a)) => a -> String+  toString = toStringG++instance ToString Bool where+  toString = show++instance ToString Int where+  toString = show++instance ToString () where+  toString = show++toStringG :: forall a . (HasEot a, ToStringG (Eot a)) => a -> String+toStringG a =+  toStringConss+    (constructors (datatype (Proxy :: Proxy a)))+    (toEot a)++class ToStringG a where+  toStringConss :: [Constructor] -> a -> String++instance (ToStringFields a, ToStringG b) => ToStringG (Either a b) where+  toStringConss (Constructor name fieldMeta : _) (Left fields) =+    name ++ format (toStringFields fields)+    where+      format fieldStrings = case fieldMeta of+        Selectors names ->+          " {" ++ intercalate ", "+            (zipWith (\ sel v -> sel ++ " = " ++ v) names fieldStrings) +++          "}"+        NoSelectors _ -> " " ++ unwords fieldStrings+        NoFields -> ""+  toStringConss (_ : r) (Right next) =+    toStringConss r next+  toStringConss [] _ = error "impossible"++instance ToStringG Void where+  toStringConss _ void = seq void (error "impossible")++class ToStringFields a where+  toStringFields :: a -> [String]++instance (ToString x, ToStringFields xs) => ToStringFields (x, xs) where+  toStringFields (x, xs) = toString x : toStringFields xs++instance ToStringFields () where+  toStringFields () = []
+ generics-eot.cabal view
@@ -0,0 +1,92 @@+-- This file has been generated from package.yaml by hpack version 0.8.0.+--+-- see: https://github.com/sol/hpack++name:           generics-eot+version:        0.1+synopsis:       A library for generic programming that aims to be easy to understand+category:       Generics+homepage:       https://github.com/soenkehahn/generics-eot#readme+bug-reports:    https://github.com/soenkehahn/generics-eot/issues+maintainer:     soenkehahn@gmail.com+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10++extra-source-files:+    README.md++source-repository head+  type: git+  location: https://github.com/soenkehahn/generics-eot++library+  hs-source-dirs:+      src+  ghc-options: -Wall -fno-warn-name-shadowing+  build-depends:+      base == 4.*+  exposed-modules:+      Generics.Eot+      Generics.Eot.Tutorial+  other-modules:+      Generics.Eot.Datatype+      Generics.Eot.Eot+  default-language: Haskell2010++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  hs-source-dirs:+      test+    , src+    , examples+  ghc-options: -Wall -fno-warn-name-shadowing+  build-depends:+      base == 4.*+    , hspec+    , QuickCheck+    , interpolate+    , doctest+  other-modules:+      Examples.CatamorphismsSpec+      Examples.DocsSpec+      Examples.MinBoundSpec+      Examples.ToStringSpec+      Generics.DatatypeSpec+      Generics.Eot.TutorialSpec+      Generics.EotSpec+      Generics.Eot+      Generics.Eot.Datatype+      Generics.Eot.Eot+      Generics.Eot.Tutorial+      Catamorphisms+      Docs+      MinBound+      ToString+  default-language: Haskell2010++test-suite quickcheck+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  hs-source-dirs:+      test/quickcheck+    , src+  ghc-options: -Wall -fno-warn-name-shadowing+  build-depends:+      base == 4.*+    , hspec+    , mockery+    , interpolate+    , shake+    , directory+    , filepath+    , QuickCheck+  other-modules:+      DatatypeSpec+      Generics.Eot+      Generics.Eot.Datatype+      Generics.Eot.Eot+      Generics.Eot.Tutorial+  default-language: Haskell2010
+ src/Generics/Eot.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | @generics-eot@ tries to be a library for datatype generic programming+-- that is easy to understand. "eot" stands for "eithers of tuples".+--+-- A tutorial on how to use @generics-eot@ can be found here:+-- "Generics.Eot.Tutorial".+module Generics.Eot (+  HasEot(..),++  -- * Meta Information+  Datatype(..),+  Constructor(..),+  Fields(..),++  -- * Void+  Void,+  -- * Useful Re-exports+  Generic,+  Proxy(..),+  ) where++import           Data.Proxy+import           GHC.Exts (Constraint)+import           GHC.Generics hiding (Datatype, Constructor)++import           Generics.Eot.Datatype+import           Generics.Eot.Eot++-- | An instance (@'HasEot' a@) allows us to+--+-- - convert values of an arbitrary algebraic datatype @a@ to and from a generic+--   representation (@'Eot' a@) (see 'toEot' and 'fromEot').+-- - extract meta information about the type @a@ (see 'datatype').+--+-- Once an algebraic datatype has an instance for 'GHC.Generics.Generic' it+-- automatically gets one for 'HasEot'.+class HasEot a where+  -- | 'Eot' is a type level function that maps arbitrary ADTs to isomorphic+  -- generic representations. Here's an example:+  --+  -- > data Foo = A Int Bool | B String+  --+  -- would be mapped to:+  --+  -- > Either (Int, (Bool, ())) (Either (String, ()) Void)+  --+  -- These representations follow these rules:+  --+  -- - The choice between constructors is mapped to right-nested 'Either's.+  -- - There's always a so-called end-marker 'Void'. It's an invalid choice (and+  --   'Void' is uninhabited to make sure you don't accidentally create such a value).+  --   So e.g. @data Foo = A@ would be mapped to @Either () Void@, and a type+  --   with no constructors is mapped to @Void@.+  -- - The fields of one constructor are mapped to right-nested tuples.+  -- - Again there's always an end-marker, this time of type @()@.+  --   A constructor with three fields @a@, @b@, @c@ is mapped to+  --   @(a, (b, (c, ())))@, one field @a@ is mapped to @(a, ())@, and no+  --   fields are mapped to @()@ (just the end-marker).+  --+  -- These rules (and the end-markers) are necessary to make sure generic+  -- functions know exactly which parts of the generic representation are field+  -- types and which parts belong to the generic skeleton.+  type Eot a :: *++  -- | Convert a value of type @a@ to its generic representation.+  toEot :: a -> Eot a++  -- | Convert a value in a generic representation to @a@ (inverse of 'toEot').+  fromEot :: Eot a -> a++  -- | Extract meta information about the ADT.+  datatype :: Proxy a -> Datatype++instance (Generic a, ImpliedByGeneric a c f) => HasEot a where+  type Eot a = EotG (Rep a)+  toEot = toEotG . from+  fromEot = to . fromEotG+  datatype Proxy = datatypeC (Proxy :: Proxy (Rep a))++type family ImpliedByGeneric a c f :: Constraint where+  ImpliedByGeneric a c f =+    (GenericDatatype (Rep a),+     Rep a ~ D1 c f,+     GenericConstructors f,+     HasEotG (Rep a))
+ src/Generics/Eot/Datatype.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Generics.Eot.Datatype where++import           Data.Maybe+import           Data.Proxy+import qualified GHC.Generics as GHC+import           GHC.Generics hiding (Datatype(..), Constructor(..))++-- | Type for meta information about ADTs.+data Datatype+  = Datatype {+    datatypeName :: String, -- ^ unqualified name of the type+    constructors :: [Constructor]+  }+  deriving (Show, Eq)++data Constructor+  = Constructor {+    constructorName :: String,+    fields :: Fields+  }+  deriving (Show, Eq)++-- | Type that represents meta information about fields of one+-- constructor.+data Fields+  = Selectors [String]+    -- ^ Record constructor, containing the list of the selector names.+  | NoSelectors Int+    -- ^ Constructor with fields, but without selector names.+    -- The argument gives the number of fields.+  | NoFields+    -- ^ Constructor without fields.+  deriving (Show, Eq)++-- * datatype++class GenericDatatype (a :: * -> *) where+  datatypeC :: Proxy a -> Datatype++instance (GHC.Datatype c, GenericConstructors f) =>+  GenericDatatype (D1 c f) where+    datatypeC Proxy = Datatype n constructors+      where+        n = GHC.datatypeName (undefined :: D1 c f x)+        constructors = getConstructors (Proxy :: Proxy f)++-- * constructors++class GenericConstructors (a :: * -> *) where+  getConstructors :: Proxy a -> [Constructor]++instance (GenericConstructors a, GenericConstructors b) =>+  GenericConstructors (a :+: b) where+    getConstructors Proxy = getConstructors a ++ getConstructors b+      where+        a :: Proxy a = Proxy+        b :: Proxy b = Proxy++instance (GHC.Constructor c, GenericFields f) =>+  GenericConstructors (C1 c f) where+    getConstructors Proxy = [Constructor n (getFields f)]+      where+        n = GHC.conName (undefined :: (C1 c f x))+        f :: Proxy f = Proxy++instance GenericConstructors V1 where+  getConstructors Proxy = []++-- * fields++getFields :: GenericFields a => Proxy a -> Fields+getFields proxy = case getFieldsC proxy of+  [] -> NoFields+  l@(Nothing : _) -> NoSelectors (length l)+  l@(Just _ : _) -> Selectors (catMaybes l)++class GenericFields (a :: * -> *) where+  getFieldsC :: Proxy a -> [Maybe String]++instance (GenericFields a, GenericFields b) =>+  GenericFields (a :*: b) where+    getFieldsC Proxy = getFieldsC a ++ getFieldsC b+      where+        a :: Proxy a = Proxy+        b :: Proxy b = Proxy++instance Selector c => GenericFields (S1 c (Rec0 f)) where+  getFieldsC proxy = [getField proxy]++getField :: forall c f . Selector c =>+  Proxy (S1 c (Rec0 f)) -> Maybe String+getField Proxy = case selName (undefined :: S1 c (Rec0 f) x) of+  "" -> Nothing+  s -> Just s++instance GenericFields U1 where+  getFieldsC Proxy = []
+ src/Generics/Eot/Eot.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Generics.Eot.Eot (+  HasEotG(..),+  Void,+  ) where++import           Data.Proxy+import           GHC.Generics++-- * datatype++class HasEotG (a :: * -> *) where+  type EotG a :: *+  toEotG :: a x -> EotG a+  fromEotG :: EotG a -> a x++instance HasConstructorsG f => HasEotG (D1 c f) where+  type EotG (D1 c f) = Constructors f+  toEotG (M1 x) = toEotConstructors x+  fromEotG x = M1 $ fromEotConstructors x++-- * constructors++class HasConstructorsG (a :: * -> *) where+  type Constructors a :: *+  toEotConstructors :: a x -> Constructors a+  fromEotConstructors :: Constructors a -> a x++instance (HasConstructorsG a, HasConstructorsG b, Normalize (Constructors a) (Constructors b)) =>+  HasConstructorsG (a :+: b) where+    type Constructors (a :+: b) = GEither (Constructors a) (Constructors b)+    toEotConstructors = \ case+      L1 a -> gLeft (toEotConstructors a) (Proxy :: Proxy (Constructors b))+      R1 b -> gRight (Proxy :: Proxy (Constructors a)) (toEotConstructors b)+    fromEotConstructors x = case gEither x of+      Left a -> L1 (fromEotConstructors a)+      Right b -> R1 (fromEotConstructors b)++instance HasFieldsG f => HasConstructorsG (C1 c f) where+  type Constructors (C1 c f) = Either (Fields f) Void+  toEotConstructors = Left . toEotFields . unM1+  fromEotConstructors = \ case+    Left fields -> M1 $ fromEotFields fields+    Right void -> seq void (error "impossible")++-- | Uninhabited type.+data Void+  deriving (Generic)++deriving instance Show Void+deriving instance Eq Void+deriving instance Ord Void++instance HasConstructorsG V1 where+  type Constructors V1 = Void+  toEotConstructors v1 = seq v1 (error "impossible")+  fromEotConstructors void = seq void (error "impossible")++-- * GEither++class Normalize a b where+  type GEither a b :: *+  gLeft :: a -> Proxy b -> GEither a b+  gRight :: Proxy a -> b -> GEither a b+  gEither :: GEither a b -> Either a b++instance Normalize b c => Normalize (Either a b) c where+  type GEither (Either a b) c = Either a (GEither b c)+  gLeft (Left a) Proxy = Left a+  gLeft (Right b) Proxy = Right $ gLeft b (Proxy :: Proxy c)+  gRight Proxy c = Right $ gRight (Proxy :: Proxy b) c+  gEither :: Either a (GEither b c) -> Either (Either a b) c+  gEither = \ case+    Left a -> Left (Left a)+    Right g -> case gEither g of+      Left b -> Left (Right b)+      Right c -> Right c++instance Normalize Void b where+  type GEither Void b = b+  gLeft void Proxy = seq void (error "impossible")+  gRight Proxy b = b+  gEither :: b -> Either Void b+  gEither = Right++-- * fields++class HasFieldsG (a :: * -> *) where+  type Fields a :: *+  toEotFields :: a x -> Fields a+  fromEotFields :: Fields a -> a x++instance (HasFieldsG a, HasFieldsG b, Concat (Fields a) (Fields b)) =>+  HasFieldsG (a :*: b) where+    type Fields (a :*: b) = Fields a +++ Fields b+    toEotFields (a :*: b) = toEotFields a +++ toEotFields b+    fromEotFields x = case unConcat x of+      (a, b) -> fromEotFields a :*: fromEotFields b++instance HasFieldsG (S1 c (Rec0 f)) where+  type Fields (S1 c (Rec0 f)) = (f, ())+  toEotFields (M1 (K1 x)) = (x, ())+  fromEotFields (x, ()) = M1 $ K1 x++instance HasFieldsG U1 where+  type Fields U1 = ()+  toEotFields U1 = ()+  fromEotFields () = U1++-- * heterogenous lists++class Concat a b where+  type a +++ b :: *+  (+++) :: a -> b -> (a +++ b)+  unConcat :: (a +++ b) -> (a, b)++instance Concat as bs => Concat (a, as) bs where+  type (a, as) +++ bs = (a, as +++ bs)+  (a, as) +++ bs = (a, as +++ bs)+  unConcat :: (a, as +++ bs) -> ((a, as), bs)+  unConcat (a, rest) = case unConcat rest of+    (as, bs) -> ((a, as), bs)++instance Concat () bs where+  type () +++ bs = bs+  () +++ bs = bs+  unConcat :: bs -> ((), bs)+  unConcat bs = ((), bs)
+ src/Generics/Eot/Tutorial.hs view
@@ -0,0 +1,518 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}++-- | This tutorial is meant to be read alongside with the haddock comments in+-- "Generics.Eot".+--+-- @generics-eot@ allows roughly three different kinds of operations:+--+-- 1. Accessing meta information about ADTs ('datatype' for names, 'Proxy' and+--    'Eot' for field types). Example: Generation of database schemas for ADTs.+-- 2. Deconstructing values generically ('toEot'). Example: Serialization to a+--    binary format.+-- 3. Constructing values of an ADT generically ('fromEot').+--    Example: Deserialization from a binary format.+--+-- Sometimes only one of the three forms is used but often multiple have to+-- be combined. For example serialization to JSON usually+-- requires both 'datatype' and+-- 'toEot'.++module Generics.Eot.Tutorial where++import           Data.Char+import           Data.List+import           Data.Typeable++import           Generics.Eot++-- * #1stExample# 1st Example: Meta Information Without Types: Field Names++-- | This simple function extracts the names of all field selectors and returns+-- them as a list:+--+-- >>> namesOfFields (Proxy :: Proxy A)+-- ["foo","bar","baz"]+--+-- (You're encouraged to look at the source code of the examples in this+-- tutorial to understand how they work. If you're looking at a web page+-- generated by haddock, you'll hopefully find @Source@ links to the right.)+namesOfFields :: HasEot a => Proxy a -> [String]+namesOfFields proxy =+  nub $+  concatMap (fieldNames . fields) $+  constructors $ datatype proxy+  where+    fieldNames :: Fields -> [String]+    fieldNames fields = case fields of+      Selectors names -> names+      _ -> []++data A = A1 {+    foo :: String,+    bar :: Int+  }+  | A2 {+    bar :: Int,+    baz :: Bool+  }+  deriving (Generic, Show)++-- * The 'Generic' instance: Don't forget!!!++-- $ To be able to use generic functions that are written with @generics-eot@+-- you need to derive an instance for 'GHC.Generics.Generic' (using+-- @DeriveGeneric@) for your ADTs. This will automatically give you an instance+-- for 'HasEot'.+--+-- When the instance for 'GHC.Generics.Generic' is missing the type error+-- messages are unfortunately very confusing and unhelpful. They go something+-- like this:+--+-- >    Couldn't match type ‘GHC.Generics.Rep WithoutGeneric’+-- >                   with ‘GHC.Generics.D1 c f’+-- >    The type variables ‘c’, ‘f’ are ambiguous+-- >    In the expression: namesOfFields (Proxy :: Proxy WithoutGeneric)+--+-- So don't forget: you need a 'Generic' instance.++-- ** 'Eot': Isomorphic representations++-- $ Part of the type class 'HasEot' is the type-level function 'Eot' that maps+-- ADTs to isomorphic types.+-- These isomorphic types are always a combination of 'Either's, tuples and+-- the uninhabited type 'Void'. For example this type:++data B = B1 Int | B2 String Bool | B3+  deriving (Generic)++-- $ would be mapped to+-- @'Either' ('Int', ()) ('Either' ('String', ('Bool', ())) ('Either' () 'Void'))@.+-- (For the exact rules of this mapping see here: 'Eot'.)+--+-- If we have an ADT @a@ then we can convert values of type @a@ to this+-- isomorphic representation+-- @'Eot' a@ with 'toEot' and we can convert in the other direction with+-- 'fromEot'. Generic functions always operate on these isomorphic+-- representations and then convert from or to the real ADTs with 'fromEot' and+-- 'toEot'.+--+-- These generic isomorphic types are referred to as "eot" -- short for+-- "'Either's of tuples".++-- * #2ndExample# 2nd Example: Deconstructing Values: Serialization++-- $ We start by writing a function that operates on the eot representations.+-- The eot representations follow simple patterns and always look similar, but+-- they don't look exactly the same for different ADTs.+-- For this reason we have to use a type class:++class EotSerialize eot where+  eotSerialize :: Int -- ^ The number of the constructor being passed in+    -> eot -- ^ The eot representation+    -> [Int] -- ^ A simple serialization format++-- $ Now we need to write instances for the types that occur in eot types.+-- (Please, look at the source code to see the instance implementations.)+-- Usually these are:+--+-- - @'Either' this next@:+--+--     - If as eot value we get @'Left' this@ it means that the original value+--     was constructed with the constructor that corresponds to @this@. In this+--     case we put the number of the constructor into the output and continue+--     with serializing the fields of type @this@.+--     - If we get @'Right' rest@ it means that one of the following+--     constructors was the one that the original value was built with. We+--     continue by increasing the constructor counter and serializing the value+--     of type @rest@.+--+--     Note that this results in 'EotSerialize' class constraints for both+--     @this@ and @rest@. If we write the correct instances for all eot types+--     these constraints should always be fulfilled.++instance (EotSerialize this, EotSerialize next) =>+  EotSerialize (Either this next) where++  eotSerialize n (Left fields) = n : eotSerialize n fields+  eotSerialize n (Right next) = eotSerialize (succ n) next++-- $+-- - 'Void':+--     We need this instance to make the compiler happy, but it'll never be+--     used. If you look at the type you can also see that: an argument of type+--     'Void' cannot be constructed.++instance EotSerialize Void where+  eotSerialize _ void = seq void $ error "impossible"++-- $+-- - @(x, xs)@:+--     Right-nested 2-tuples are used to encode all the fields for one specific+--     constructor. So @x@ is the current field and @xs@ are the remaining+--     fields. To serialize this we serialize @x@ (using 'serialize')+--     and also write the length of the+--     resulting list into the output. This will allow deserialization.+--+--     Note: We could use 'EotSerialize' to serialize the fields. But that would+--     be a bit untrue to the spirit, since the fields are not eot types. Apart+--     from that we might want to encode a field of e.g. type @'Either' a b@+--     differently than the eot type @'Either' a b@. So we use a very similar+--     but distinct type class called 'Serialize'.+--+--     The value of type @xs@ contains the remaining fields and will be encoded+--     recursively with 'eotSerialize'.++instance (Serialize x, EotSerialize xs) => EotSerialize (x, xs) where+  eotSerialize n (x, xs) =+    let xInts = serialize x+    in length xInts : xInts ++ eotSerialize n xs++-- $+-- - @()@:+--     Finally we need an instance for the unit type that marks the end of the+--     fields encoded in 2-tuples. Since @()@ doesn't carry any information, we+--     can encode it as the empty list.++instance EotSerialize () where+  eotSerialize _ () = []++-- | This is the class 'Serialize'. It's used to serialize every field of the+-- used ADTs, so we need instances for all of them.+class Serialize a where+  serialize :: a -> [Int]+  default serialize :: (HasEot a, EotSerialize (Eot a)) => a -> [Int]+  serialize = genericSerialize++instance Serialize Int where+  serialize i = [i]++instance Serialize String where+  serialize = map ord++instance Serialize Bool where+  serialize True = [1]+  serialize False = [0]++instance Serialize () where+  serialize () = []++-- | To tie everything together we provide a function 'genericSerialize' that+-- converts a value of some ADT into an eot value using 'toEot' and then uses+-- 'eotSerialize' to convert that eot value into a list of 'Int's.+genericSerialize :: (HasEot a, EotSerialize (Eot a)) => a -> [Int]+genericSerialize = eotSerialize 0 . toEot++-- $ And it works too:+--+-- >>> genericSerialize (A1 "foo" 42)+-- [0,3,102,111,111,1,42]+-- >>> genericSerialize (A2 23 True)+-- [1,1,23,1,1]++-- * #3rdExample# 3rd Example: Constructing Values: Deserialization++-- $ Deserialization works very similarly. It differs in that the functions turn+-- lists of 'Int's into eot values.+--+-- Here's the 'EotDeserialize' class with instances for:+--+--  - @'Either' this next@+--  - @'Void'@+--  - @(x, xs)@+--  - @()@++class EotDeserialize eot where+  eotDeserialize :: [Int] -> eot++instance (EotDeserialize this, EotDeserialize next) =>+  EotDeserialize (Either this next) where++  eotDeserialize (0 : r) = Left $ eotDeserialize r+  eotDeserialize (n : r) = Right $ eotDeserialize (pred n : r)+  eotDeserialize [] = error "invalid input"++instance EotDeserialize Void where+  eotDeserialize _ = error "invalid input"++instance (Deserialize x, EotDeserialize xs) =>+  EotDeserialize (x, xs) where++  eotDeserialize (len : r) =+    let (this, rest) = splitAt len r+    in (deserialize this, eotDeserialize rest)+  eotDeserialize [] = error "invalid input"++instance EotDeserialize () where+  eotDeserialize [] = ()+  eotDeserialize (_ : _) = error "invalid input"++-- $ And here's the 'Deserialize' class plus all instances to deserialize the+-- fields:++class Deserialize a where+  deserialize :: [Int] -> a++instance Deserialize Int where+  deserialize [n] = n+  deserialize _ = error "invalid input"++instance Deserialize String where+  deserialize = map chr++instance Deserialize () where+  deserialize [] = ()+  deserialize (_ : _) = error "invalid input"++instance Deserialize Bool where+  deserialize [0] = False+  deserialize [1] = True+  deserialize _ = error "invalid input"++-- | And here's 'genericDeserialize' to tie it together. It uses+-- 'eotDeserialize' to convert a list of 'Int's into an eot value and then+-- 'fromEot' to construct a value of the wanted ADT.+genericDeserialize :: (HasEot a, EotDeserialize (Eot a)) => [Int] -> a+genericDeserialize = fromEot . eotDeserialize++-- $ Here you can see it in action:+--+-- >>> genericDeserialize [0,3,102,111,111,1,42] :: A+-- A1 {foo = "foo", bar = 42}+-- >>> genericDeserialize [1,1,23,1,1] :: A+-- A2 {bar = 23, baz = True}+--+-- And it is the inverse of 'genericSerialize':+--+-- >>> (genericDeserialize $ genericSerialize $ A1 "foo" 42) :: A+-- A1 {foo = "foo", bar = 42}++-- * 4th Example: Meta Information with types: generating SQL schemas++-- $ Accessing meta information __including__ the types works very+-- similarly to deconstructing or constructing values. It uses the same+-- structure of type classes and instances for the eot-types. The difference is:+-- since we don't want actual values of our ADT as input or output we operate on+-- 'Proxy's of our eot-types.+--+-- As an example we're going to implement a function that generates SQL+-- statements that create tables that our ADTs would fit into. To be able to+-- use nice names for the table and columns we're going to traverse the+-- type-less meta information (see <#1stExample 1st example>) at the same time.+--+-- (Note that the generated SQL statements are targeted at a fictional+-- database implementation that magically understands Haskell types like+-- 'Int' and 'String', or rather @['Char']@.)+--+-- Again we start off by writing a class that operates on the eot-types. Besides+-- the eot-type the class has an additional parameter, @meta@, that will be+-- instantiated by the corresponding types used for untyped meta information.++class EotCreateTableStatement meta eot where+  eotCreateTableStatement :: meta -> Proxy eot -> [String]++-- $ Our first instance is for the complete datatype. @eot@ is instantiated to+-- @'Either' fields 'Void'@. Note that this instance only works for ADTs with+-- exactly one constructor as we don't support types with multiple constructors.+-- @meta@ is instantiated to 'Datatype' which is the type for meta information+-- for ADTs.++instance EotCreateTableStatement [String] fields =>+  EotCreateTableStatement Datatype (Either fields Void) where++  eotCreateTableStatement datatype Proxy = case datatype of+    Datatype name [Constructor _ (Selectors fields)] ->+      "CREATE TABLE " :+      name :+      " COLUMNS " :+      "(" :+      intercalate ", " (eotCreateTableStatement fields (Proxy :: Proxy fields)) :+      ");" :+      []+    Datatype _ [Constructor name (NoSelectors _)] ->+      error ("constructor " ++ name ++ " has no selectors, this is not supported")+    Datatype name _ ->+      error ("type " ++ name ++ " must have exactly one constructor")++-- $ The second instance is responsible for creating the parts of the SQL+-- statements that declare the columns. As such it has to traverse the fields+-- of our ADT. @eot@ is instantiated to the usual @(x, xs)@. @meta@ is+-- instantiated to @['String']@, representing the field names. The name of the+-- field type is obtained using 'typeRep', therefore we need a @'Typeable' x@+-- constraint.++instance (Typeable x, EotCreateTableStatement [String] xs) =>+  EotCreateTableStatement [String] (x, xs) where++  eotCreateTableStatement (field : fields) Proxy =+    (field ++ " " ++ show (typeRep (Proxy :: Proxy x))) :+    eotCreateTableStatement fields (Proxy :: Proxy xs)+  eotCreateTableStatement [] Proxy = error "impossible"++-- $ The last instances is for @()@. It's needed as the base case for+-- traversing the fields and as such returns just an empty list.++instance EotCreateTableStatement [String] () where+  eotCreateTableStatement [] Proxy = []+  eotCreateTableStatement (_ : _) Proxy = error "impossible"++-- | 'createTableStatement' ties everything together. It obtaines the meta+-- information through 'datatype' passing a 'Proxy' for @a@. And it creates a+-- 'Proxy' for the eot-type:+--+-- > Proxy :: Proxy (Eot a)+--+-- Then it calls 'eotCreateTableStatement' and just 'concat's the resulting+-- snippets.+createTableStatement :: forall a . (HasEot a, EotCreateTableStatement Datatype (Eot a)) =>+  Proxy a -> String+createTableStatement proxy =+  concat $ eotCreateTableStatement (datatype proxy) (Proxy :: Proxy (Eot a))++-- $ As an example, we're going to use 'Person':++data Person+  = Person {+    name :: String,+    age :: Int+  }+  deriving (Generic)++-- $ And here's the created SQL statement:+--+-- >>> putStrLn $ createTableStatement (Proxy :: Proxy Person)+-- CREATE TABLE Person COLUMNS (name [Char], age Int);+--+-- If we try to use an ADT with multiple constructors, we get a type error+-- due to a missing instance:+--+-- >>> putStrLn $ createTableStatement (Proxy :: Proxy A)+-- <BLANKLINE>+-- ...+--     No instance for (EotCreateTableStatement+--                        Datatype+--                        (Either ([Char], (Int, ())) (Either (Int, (Bool, ())) Void)))+--       arising from a use of ‘createTableStatement’+-- ...+--+-- If we try to use it with an ADT with a single constructor but no selectors,+-- we get a runtime error:++data NoSelectors+  = NotSupported Int Bool+  deriving (Generic)++-- $ >>> putStrLn $ createTableStatement (Proxy :: Proxy NoSelectors)+-- *** Exception: constructor NotSupported has no selectors, this is not supported++-- * DefaultSignatures++-- $ There is a GHC language extension called @<https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/type-class-extensions.html#class-default-signatures DefaultSignatures>@.+-- In itself it has little to do with generic programming, but it makes a good+-- companion.++-- ** How DefaultSignatures work:++-- $ Imagine you have a type class called @ToString@ which allows to convert+-- values to 'String's:++class ToString a where+  toString :: a -> String+  default toString :: Show a => a -> String+  toString = show++-- $ You can write instances manually, but you might be tempted to give the+-- following default implementation for 'toString':+--+-- > toString = show+--+-- The idea is that then you can just write down an empty 'ToString' instance:+--+-- > instance ToString A+--+-- and you get to use 'toString' on values of type 'A' for free.+--+-- But that default implementation doesn't work, because in the class declaration+-- we don't have an instance for @Show a@. ghc says:+--+-- > Could not deduce (Show a) arising from a use of ‘show’+-- > from the context (ToString a)+--+-- One solution would be to make 'ToString' a subclass of 'Show', but then we+-- cannot implement 'ToString' instances manually anymore for types that don't+-- have a 'Show' instance. @DefaultSignatures@ provide a better solution. The+-- extension allows you to further narrow down the type for your default+-- implementation for class methods:+--+-- > class ToString a where+-- >   toString :: a -> String+-- >   default toString :: Show a => a -> String+-- >   toString = show+--+-- Then writing down empty instances work for types that have a 'Show' instance:+--+-- > instance ToString Int++instance ToString Int++-- $ >>> toString (42 :: Int)+-- "42"++-- $ Note: if you write down an empty @ToString@ instances for a type that+-- does not have a 'Show' instance, the error message looks like this:+--+-- > No instance for (Show NoShow)+--+-- This might be confusing especially since haddock docs don't list the default+-- signatures or implementations and users of the class might be wondering why+-- 'Show' comes into play at all.++-- ** How to use @DefaultSignatures@ for generic programming:++-- $ @DefaultSignatures@ are especially handy when doing generic programming.+-- Remember the type class 'Serialize' from the second example? Initially we+-- used it to serialize the fields of our ADTs in the generic serialization+-- through 'genericSerialize' and 'EotSerialize'. We just assumed that we would+-- have a manual implementation for all field types. But with+-- @DefaultSignatures@ we can now give a default implementation that uses+-- 'genericSerialize':+--+-- > class Serialize a where+-- >   serialize :: a -> [Int]+-- >   default serialize :: (HasEot a, EotSerialize (Eot a)) => a -> [Int]+-- >   serialize = genericSerialize+--+-- Note that the default implementation is given by 'genericSerialize' and has+-- the same constraints.+--+-- Now we can write empty instances for custom ADTs:++data C+  = C1 Int String+  deriving (Generic)++-- $+-- > instance Serialize C++instance Serialize C++-- $ You could say that by giving this empty instance we give our blessing to+-- use 'genericSerialize' for this type, but we don't have to actually implement+-- anything. And it works:+--+-- >>> serialize (C1 42 "yay!")+-- [0,1,42,4,121,97,121,33]++-- $ Important is that we still have the option to implement instances manually+-- by overwriting the default implementation. This is needed for basic types+-- like 'Int' and 'Char' that don't have useful generic representations. But it+-- also allows us to overwrite instances for ADTs manually. For example you may+-- want a certain type to be serialized in a special way that deviates from the+-- generic implementation or you may implement an instance manually for+-- performance gain.
+ test/Examples/CatamorphismsSpec.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Examples.CatamorphismsSpec where++import           Data.Proxy+import           Generics.Eot+import           Test.Hspec++import           Catamorphisms++spec :: Spec+spec = do+  describe "catamorphism" $ do+    it "works for one constructor, no fields" $ do+      catamorphism A (Proxy :: Proxy String) "foo"+        `shouldBe` "foo"++    it "works for one constructor, one field" $ do+      catamorphism (B 42) (Proxy :: Proxy String)+        show `shouldBe` "42"++    it "works for two constructors, no fields" $ do+      catamorphism C2 (Proxy :: Proxy String)+        "1" "2" `shouldBe` "2"++    it "works for more complex types" $ do+      let cata :: forall a . D -> (Int -> a) -> a -> (String -> Bool -> a) -> a+          cata d = catamorphism d (Proxy :: Proxy a)+          f d = cata d show "unit" (\ a b -> show (a, b))+      f (D1 42) `shouldBe` "42"+      f D2 `shouldBe` "unit"+      f (D3 "foo" True) `shouldBe` "(\"foo\",True)"++data A+  = A+  deriving (Generic)++data B+  = B Int+  deriving (Generic)++data C+  = C1 | C2+  deriving (Generic)++data D+  = D1 Int+  | D2+  | D3 String Bool+  deriving (Generic)
+ test/Examples/DocsSpec.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Examples.DocsSpec where++import           Data.String.Interpolate+import           Data.String.Interpolate.Util+import           Test.Hspec++import           Docs+import           Generics.Eot++spec :: Spec+spec = do+  describe "docs" $ do+    it "works" $ do+      docs (Proxy :: Proxy Test) `stringCompare` unindent [i|+        Datatype Test has 3 constructors:++        1. Constructor "A" with the following fields:+          - [Char] (example: "foo")+          - () (example: ())+        2. Constructor "B" with the following fields:+          - a :: Bool (example: True)+          - b :: Either () [Char] (example: Right "foo")+        3. Constructor "C" with no fields+      |]++stringCompare :: String -> String -> IO ()+stringCompare a b+  | prefix <= 3 = a `shouldBe` b+  | otherwise =+      let f s = "..." ++ drop (prefix - 10) s+      in f a `shouldBe` f b+  where+    prefix = prefixH 0 a b+    prefixH n x y = case (x, y) of+      (a : as, b : bs) | a == b ->+        prefixH (succ n) as bs+      _ -> n++data Test+  = A String ()+  | B { a :: Bool, b :: Either () String }+  | C+  deriving (Generic)++instance HasSample Bool where+  sample = True++instance HasSample String where+  sample = "foo"++instance HasSample b => HasSample (Either a b) where+  sample = Right sample++instance HasSample () where+  sample = ()
+ test/Examples/MinBoundSpec.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE DeriveGeneric #-}++module Examples.MinBoundSpec where++import           Data.Word+import           Test.Hspec++import           Generics.Eot+import           MinBound++spec :: Spec+spec = do+  describe "minBoundG" $ do+    it "works" $ do+      minBoundG `shouldBe` Foo minBound 0 False++data Foo+  = Foo Int Word8 Bool+  deriving (Eq, Show, Generic)
+ test/Examples/ToStringSpec.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}++module Examples.ToStringSpec where++import           Test.Hspec++import           Generics.Eot+import           ToString++data Test+  = A {+    a :: Int,+    b :: (),+    c :: Bool+  }+  | B+  deriving (Generic, ToString)++spec :: Spec+spec = do+  describe "toString" $ do+    it "works" $ do+      toString (A 42 () False) `shouldBe` "A {a = 42, b = (), c = False}"
+ test/Generics/DatatypeSpec.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE DeriveGeneric #-}++module Generics.DatatypeSpec where++import qualified GHC.Generics as GHC+import           Test.Hspec hiding (Selector)++import           Generics.Eot++data TestType+  = A+  | B {+    a :: String+  }+  | C {+    a :: String,+    b :: Int,+    c :: Bool,+    d :: ()+  }+  | D String+  deriving (GHC.Generic, Show)++spec :: Spec+spec = do+  describe "datatype" $ do+    it "returns meta data about record types" $ do+      let expected = Datatype "TestType" $+            Constructor "A" NoFields :+            Constructor "B" (Selectors ["a"]) :+            Constructor "C" (Selectors ["a", "b", "c", "d"]) :+            Constructor "D" (NoSelectors 1) :+            []+      datatype (Proxy :: Proxy TestType) `shouldBe` expected
+ test/Generics/Eot/TutorialSpec.hs view
@@ -0,0 +1,12 @@++module Generics.Eot.TutorialSpec where++import           Test.DocTest+import           Test.Hspec++import           Generics.Eot.Tutorial ()++spec :: Spec+spec = describe "tutorial" $ do+  it "doctests" $ do+    doctest (words "src/Generics/Eot/Tutorial.hs -isrc")
+ test/Generics/EotSpec.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Generics.EotSpec where++import           Test.Hspec+import           Test.QuickCheck++import           Generics.Eot++spec :: Spec+spec = do+  describe "toEot" $ do+    it "works" $ do+      toEot (A 42 "foo" True ()) `shouldBe`+        Left (42, ("foo", (True, ((), ()))))+      toEot (B True) `shouldBe` Right (Left (True, ()))+      toEot Foo `shouldBe` Left ()++    it "produces the right types" $ do+      let _foo :: Either+            (Int, (String, (Bool, ((), ()))))+            (Either (Bool, ())+             (Either ()+              (Either () Void)))+          _foo = toEot C+      True++  describe "fromEot" $ do+    it "is the inverse of toEot" $ do+      property $ \ eot -> not (isVoid eot) ==> do+        let a :: Test+            a = fromEot eot+        toEot a `shouldBe` eot++    it "the other way around" $ do+      property $ \ (a :: Test) -> do+        let eot :: Eot Test+            eot = toEot a+        fromEot eot `shouldBe` a++instance Arbitrary Void where+  arbitrary = error "please, don't do this!"++class IsVoid a where+  isVoid :: a -> Bool++instance IsVoid (Either b c) => IsVoid (Either a (Either b c)) where+  isVoid = \ case+    Left _ -> False+    Right bc -> isVoid bc++instance IsVoid (Either a Void) where+  isVoid = either (const False) (const True)++data Test+  = A Int String Bool ()+  | B Bool+  | C+  | D+  deriving (Generic, Show, Eq)++instance Arbitrary Test where+  arbitrary = oneof $+    (A <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary) :+    (B <$> arbitrary) :+    (pure C) :+    (pure D) :+    []++data Foo = Foo+  deriving (Generic)
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/quickcheck/DatatypeSpec.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module DatatypeSpec where++import           Data.Char+import           Data.List+import           Data.String.Interpolate+import           Data.String.Interpolate.Util+import           Development.Shake+import           System.Directory+import           System.Exit+import           System.FilePath+import           Test.Hspec hiding (Selector)+import           Test.Hspec.QuickCheck+import           Test.Mockery.Directory+import           Test.QuickCheck++import           Generics.Eot++spec :: Spec+spec = modifyMaxSize (const 20) $ modifyMaxSuccess (const 20) $ do+  describe "datatype" $ do+    it "works for every ADT" $ do+      property $ \ dt -> test dt [i|+        {-# LANGUAGE DeriveGeneric #-}++        import Generics.Eot++        main = print $ datatype (Proxy :: Proxy #{datatypeName dt})++      |]++  describe "toString" $ do+    it "works" $ do+      property $ \ dt ->+        (not $ null $ constructors dt) ==>+        test dt [i|+          {-# LANGUAGE DeriveAnyClass #-}+          {-# LANGUAGE DeriveGeneric #-}+          {-# LANGUAGE StandaloneDeriving #-}++          import Generics.Eot+          import Control.Monad++          import ToString++          main = do+            when (toString testValue /= show testValue) $+              error $ unlines $+                "" :+                ("expected: " ++ show (show testValue)) :+                ("got:      " ++ show (toString testValue)) :+                []++          deriving instance ToString #{datatypeName dt}+          deriving instance Show #{datatypeName dt}++        |]++test :: Datatype -> String -> Property+test dt testCode = do+  property $ \ n -> hasUniqueNames dt ==> ioProperty $ do+    current <- getCurrentDirectory+    inTempDirectory $ do+      let code = unindent testCode ++ "\n" +++            toDatatypeDecl dt n+      writeFile "Main.hs" code+      (Stderr output, exitCode) <-+        cmd "runhaskell"+          ("-i" ++ current </> "src")+          ("-i" ++ current </> "examples")+          "Main.hs"+      return $+        counterexample code $+        counterexample output $+        (exitCode == ExitSuccess)++toDatatypeDecl :: Datatype -> Int -> String+toDatatypeDecl (Datatype n []) _ = unindent [i|+  data #{n}+    deriving (Generic)+  |]+toDatatypeDecl dt n = unindent [i|+  data #{datatypeName dt}+    = #{intercalate " | " (map renderCons (constructors dt))}+    deriving (Generic)++  testValue :: #{datatypeName dt}+  testValue = #{testValue}+  |]+  where+    renderCons :: Constructor -> String+    renderCons = \ case+      Constructor name (Selectors fields) ->+        let render n = [i|#{n} :: Int|]+        in [i|#{name} { #{intercalate ", " (map render fields)} }|]+      Constructor name (NoSelectors n) ->+        [i|#{name} #{intercalate " " (replicate n "Int")}|]+      Constructor name NoFields -> name++    conss = constructors dt++    testValue :: String+    testValue = case conss !! (abs n `mod` length conss) of+      Constructor name fields ->+        unwords (name : replicate (numberOfFields fields) "42")++    numberOfFields :: Fields -> Int+    numberOfFields = \ case+      Selectors sels -> length sels+      NoSelectors n -> n+      NoFields -> 0++hasUniqueNames :: Datatype -> Bool+hasUniqueNames (Datatype _ conss) =+  unique (map constructorName conss) &&+  all uniqueCons (map fields conss)+  where+    unique :: Eq a => [a] -> Bool+    unique l = nub l == l++    uniqueCons = \ case+      Selectors fields -> unique fields+      _ -> True++upperCase :: [Char]+upperCase = ['A' .. 'Z']++lowerCase :: [Char]+lowerCase = ['a' .. 'z']++allLetters :: [Char]+allLetters = lowerCase ++ upperCase++arbitraryLowerName :: Gen String+arbitraryLowerName = flip suchThat (not . isKeyword) $ do+  first <- elements lowerCase+  (first :) <$> listOf (elements allLetters)++shrinkLowerName :: String -> [String]+shrinkLowerName s =+  filter isValid (shrink s)+  where+    isValid w@(s : _) = isLower s && not (isKeyword w)+    isValid [] = False++isKeyword :: String -> Bool+isKeyword s = s `elem` keywords+  where+    keywords =+      words "case class data default deriving do else foreign if import in infix infixl infixr instance let module newtype of then type where"++arbitraryUpperName :: Gen String+arbitraryUpperName = do+  first <- elements upperCase+  (first :) <$> listOf (elements allLetters)++shrinkUpperName :: String -> [String]+shrinkUpperName s =+  filter isValid (shrink s)+  where+    isValid (s : _) = isUpper s+    isValid [] = False++instance Arbitrary Datatype where+  arbitrary = Datatype <$> arbitraryUpperName <*> arbitrary+  shrink (Datatype n cs) =+    [Datatype n' cs | n' <- shrinkUpperName n] +++    [Datatype n cs' | cs' <- shrink cs]++instance Arbitrary Constructor where+  arbitrary = Constructor <$> arbitraryUpperName <*> arbitrary+  shrink (Constructor n fs) =+    [Constructor n' fs | n' <- shrinkUpperName n] +++    [Constructor n fs' | fs' <- shrink fs]++instance Arbitrary Fields where+  arbitrary = oneof $+    return NoFields :+    (Selectors <$> listOf arbitraryLowerName) :+    (NoSelectors <$> arbitrary) :+    []+  shrink = \ case+    NoFields -> []+    NoSelectors i ->+      NoFields :+      map NoSelectors (shrink i)+    Selectors fs ->+      NoSelectors (length fs) :+      nub (map Selectors (shrinkList shrinkLowerName fs))
+ test/quickcheck/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}