{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

-- These can go if the tuple instances are accepted upstream.

{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Generics (
  Generic(..),
  prepend,
  to_tuple )
where

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 ''(,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,) -- 20
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,) -- 25
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) -- 30


-- | Convert a simple product type into a tuple, generically.
--
--   ==== __Examples__:
--
--   >>> import qualified GHC.Generics as GHC ( Generic )
--   >>> data Foo = Bar Int Int Int Int deriving (Show, GHC.Generic)
--   >>> instance Generic Foo
--   >>> let b = Bar 1 2 3 4
--   >>> to_tuple b :: (Int,Int,Int,Int)
--   (1,2,3,4)
--
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