From dc53ce490d36c937a8db674e6fd3e9495247dc8b Mon Sep 17 00:00:00 2001
From: Michael Orlitzky <michael@orlitzky.com>
Date: Fri, 2 Jan 2015 12:50:27 -0500
Subject: [PATCH] Add the generic 'prepend' function to the Generics module.

---
 src/Generics.hs | 86 +++++++++++++++++++++++++++++++++++++++++++++++--
 1 file changed, 83 insertions(+), 3 deletions(-)

diff --git a/src/Generics.hs b/src/Generics.hs
index 76a8a2b..c7492e4 100644
--- a/src/Generics.hs
+++ b/src/Generics.hs
@@ -1,21 +1,26 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 
 -- These can go if the tuple instances are accepted upstream.
 
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE DataKinds #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Generics (
   Generic(..),
+  prepend,
   to_tuple )
 where
 
-import Generics.SOP ( Code, Generic(..) )
+import Generics.SOP ( Code, Generic(..), I(..), NP(..), NS(..), SOP(..) )
 import Generics.SOP.TH ( deriveGeneric )
 
+-- Derive instances for tuples of size <= 30. The predefined instances
+-- in generics-sop only go up to 15 components.
 deriveGeneric ''(,,,,,,,,,,,,,,,)
 deriveGeneric ''(,,,,,,,,,,,,,,,,)
 deriveGeneric ''(,,,,,,,,,,,,,,,,,)
@@ -32,9 +37,10 @@ deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,)
 deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,)
 deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) -- 30
 
+
 -- | Convert a simple product type into a tuple, generically.
 --
---   == __Examples__:
+--   ==== __Examples__:
 --
 --   >>> import qualified GHC.Generics as GHC ( Generic )
 --   >>> data Foo = Bar Int Int Int Int deriving (Show, GHC.Generic)
@@ -45,3 +51,77 @@ deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) -- 30
 --
 to_tuple:: (Generic a, Generic c, Code a ~ Code c) => a -> c
 to_tuple = to . from
+
+-- | This type function takes a type-level list-of-lists, @xss@, and
+--   prepends the type @a@ to each tpye-level list in @xss@.
+--
+--   The dubious '[] clause makes sense when you realize that we're
+--   appending to the inner lists, none of which exist if @xss@ is
+--   empty.
+--
+type family Prepended a (xss :: [k]) :: [l]
+type instance Prepended a '[] = '[]
+type instance Prepended a (x ': xs) = (a ': x) ': (Prepended a xs)
+
+
+-- | Prepend a value of type @a@ to a product type that is represented
+--   as a sum-of-products. The @SOP I@ part of the signature basically
+--   means that it's a plain Haskell type, represented as a sum of
+--   products. The @xss@ argument is a type-level list-of-lists
+--   representing the \"shape\" of the type.
+--
+--   We're going to prepend a value of type @a@ to our argument, no
+--   matter its constructor. So the shape of the return value will
+--   differ from the shape of the argument. How? Each constructor (one
+--   list in the list-of-lists) will have a new value of type @a@
+--   appended to it. We represent this by appending the type @a@
+--   itself to the type-level lists contained in @xss@. All of this is
+--   handled by the type family 'Prepended'.
+--
+--   ==== __Examples__
+--
+--   >>> import qualified GHC.Generics as GHC
+--   >>> data Foo = Foo Int Int | Bar Int Int Int deriving (Show, GHC.Generic)
+--   >>> instance Generic Foo
+--   >>> prepend_sop "Hello" (from $ Foo 1 2)
+--   SOP (Z (I "Hello" :* (I 1 :* (I 2 :* Nil))))
+--   >>> prepend_sop "Hello" (from $ Bar 1 2 3)
+--   SOP (S (Z (I "Hello" :* (I 1 :* (I 2 :* (I 3 :* Nil))))))
+--
+prepend_sop :: a -> SOP I xss -> SOP I (Prepended a xss)
+prepend_sop z (SOP (Z rest)) = SOP $ Z ((I z) :* rest)
+prepend_sop z (SOP (S rest)) =
+  let (SOP result) = prepend_sop z (SOP rest)
+                     in SOP $ S $ result
+
+-- | Prepend a field to a simple type, generically. This uses the
+--   magic from "Generics.SOP" to,
+--
+--    1. Convert the argumnt to a sum-of-profucts
+--    2. Use 'prepend_sop' to prepend the new value to the
+--       sum-of-products representation.
+--    3. Convert the result back to /any/ isomorphic type, not
+--       necessarily the original type!
+--
+--  You do need to indicate the type of the return value usually if it
+--  can't be inferred.
+--
+--  ==== __Examples__
+--
+--   The \"BigF\" type below matches up with \"F\", except each
+--   constructor for \"BigF\" has a 'String' field in front of
+--   it. We can convert from \"F\" to \"BigF\" by prepending a
+--   String:
+--
+--   >>> import qualified GHC.Generics as GHC
+--   >>> data F = F Int | B Int Int deriving (Show, GHC.Generic)
+--   >>> instance Generic F
+--   >>> data BigF = BigF String Int | BigB String Int Int deriving (Show, GHC.Generic)
+--   >>> instance Generic BigF
+--   >>> prepend "Hello" (F 1) :: Big
+--   BigF "Hello" 1
+--   >>> prepend "Hello" (B 1 2) :: BigF
+--   BigB "Hello" 1 2
+--
+prepend :: (Generic a, Generic c, Prepended b (Code a) ~ Code c) => b -> a -> c
+prepend z = to . (prepend_sop z) . from
-- 
2.43.2