src/Generics.hs

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE DeriveGeneric #-}
   3 {-# LANGUAGE NoMonomorphismRestriction #-}
   4 {-# LANGUAGE PolyKinds #-}
   5 {-# LANGUAGE TypeFamilies #-}
   6 {-# LANGUAGE TypeOperators #-}
   7
   8 -- These can go if the tuple instances are accepted upstream.
   9
  10 {-# LANGUAGE TemplateHaskell #-}
  11 {-# OPTIONS_GHC -fno-warn-orphans #-}
  12
  13 module Generics (
  14   Generic(..),
  15   prepend,
  16   to_tuple )
  17 where
  18
  19 import Generics.SOP ( Code, Generic(..), I(..), NP(..), NS(..), SOP(..) )
  20 import Generics.SOP.TH ( deriveGeneric )
  21
  22 -- Derive instances for tuples of size <= 30. The predefined instances
  23 -- in generics-sop only go up to 15 components.
  24 deriveGeneric ''(,,,,,,,,,,,,,,,)
  25 deriveGeneric ''(,,,,,,,,,,,,,,,,)
  26 deriveGeneric ''(,,,,,,,,,,,,,,,,,)
  27 deriveGeneric ''(,,,,,,,,,,,,,,,,,,)
  28 deriveGeneric ''(,,,,,,,,,,,,,,,,,,,) -- 20
  29 deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,)
  30 deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,)
  31 deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,)
  32 deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,)
  33 deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,) -- 25
  34 deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,)
  35 deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,)
  36 deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,)
  37 deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,)
  38 deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) -- 30
  39
  40
  41 -- | Convert a simple product type into a tuple, generically.
  42 --
  43 --   ==== __Examples__:
  44 --
  45 --   >>> import qualified GHC.Generics as GHC ( Generic )
  46 --   >>> data Foo = Bar Int Int Int Int deriving (Show, GHC.Generic)
  47 --   >>> instance Generic Foo
  48 --   >>> let b = Bar 1 2 3 4
  49 --   >>> to_tuple b :: (Int,Int,Int,Int)
  50 --   (1,2,3,4)
  51 --
  52 to_tuple:: (Generic a, Generic c, Code a ~ Code c) => a -> c
  53 to_tuple = to . from
  54
  55 -- | This type function takes a type-level list-of-lists, @xss@, and
  56 --   prepends the type @a@ to each tpye-level list in @xss@.
  57 --
  58 --   The dubious '[] clause makes sense when you realize that we're
  59 --   appending to the inner lists, none of which exist if @xss@ is
  60 --   empty.
  61 --
  62 type family Prepended a (xss :: [k]) :: [l]
  63 type instance Prepended a '[] = '[]
  64 type instance Prepended a (x ': xs) = (a ': x) ': (Prepended a xs)
  65
  66
  67 -- | Prepend a value of type @a@ to a product type that is represented
  68 --   as a sum-of-products. The @SOP I@ part of the signature basically
  69 --   means that it's a plain Haskell type, represented as a sum of
  70 --   products. The @xss@ argument is a type-level list-of-lists
  71 --   representing the \"shape\" of the type.
  72 --
  73 --   We're going to prepend a value of type @a@ to our argument, no
  74 --   matter its constructor. So the shape of the return value will
  75 --   differ from the shape of the argument. How? Each constructor (one
  76 --   list in the list-of-lists) will have a new value of type @a@
  77 --   appended to it. We represent this by appending the type @a@
  78 --   itself to the type-level lists contained in @xss@. All of this is
  79 --   handled by the type family 'Prepended'.
  80 --
  81 --   ==== __Examples__
  82 --
  83 --   >>> import qualified GHC.Generics as GHC
  84 --   >>> data Foo = Foo Int Int | Bar Int Int Int deriving (Show, GHC.Generic)
  85 --   >>> instance Generic Foo
  86 --   >>> prepend_sop "Hello" (from $ Foo 1 2)
  87 --   SOP (Z (I "Hello" :* (I 1 :* (I 2 :* Nil))))
  88 --   >>> prepend_sop "Hello" (from $ Bar 1 2 3)
  89 --   SOP (S (Z (I "Hello" :* (I 1 :* (I 2 :* (I 3 :* Nil))))))
  90 --
  91 prepend_sop :: a -> SOP I xss -> SOP I (Prepended a xss)
  92 prepend_sop z (SOP (Z rest)) = SOP $ Z ((I z) :* rest)
  93 prepend_sop z (SOP (S rest)) =
  94   let (SOP result) = prepend_sop z (SOP rest)
  95                      in SOP $ S $ result
  96
  97 -- | Prepend a field to a simple type, generically. This uses the
  98 --   magic from "Generics.SOP" to,
  99 --
 100 --    1. Convert the argumnt to a sum-of-profucts
 101 --    2. Use 'prepend_sop' to prepend the new value to the
 102 --       sum-of-products representation.
 103 --    3. Convert the result back to /any/ isomorphic type, not
 104 --       necessarily the original type!
 105 --
 106 --  You do need to indicate the type of the return value usually if it
 107 --  can't be inferred.
 108 --
 109 --  ==== __Examples__
 110 --
 111 --   The \"BigF\" type below matches up with \"F\", except each
 112 --   constructor for \"BigF\" has a 'String' field in front of
 113 --   it. We can convert from \"F\" to \"BigF\" by prepending a
 114 --   String:
 115 --
 116 --   >>> import qualified GHC.Generics as GHC
 117 --   >>> data F = F Int | B Int Int deriving (Show, GHC.Generic)
 118 --   >>> instance Generic F
 119 --   >>> data BigF = BigF String Int | BigB String Int Int deriving (Show, GHC.Generic)
 120 --   >>> instance Generic BigF
 121 --   >>> prepend "Hello" (F 1) :: Big
 122 --   BigF "Hello" 1
 123 --   >>> prepend "Hello" (B 1 2) :: BigF
 124 --   BigB "Hello" 1 2
 125 --
 126 prepend :: (Generic a, Generic c, Prepended b (Code a) ~ Code c) => b -> a -> c
 127 prepend z = to . (prepend_sop z) . from