FirstParameter.hs

{-|
A convenience class for retrieving the first field of any constructor in a
datatype.

The primary usage for this class is generic derivation:

    data D a = D a () String deriving Generic
    instance FirstParameter (D a) a

Note that _the deriver does not check you are requesting a valid/safe instance._
Invalid instances propagate the error to runtime. Fixing this requires a lot
more type-level work. (The generic-lens library has a general solution, but it's
slow and memory-consuming.)
-}

{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FunctionalDependencies #-}

module Language.Fortran.Util.FirstParameter(FirstParameter(..), GFirstParameter(..)) where

import GHC.Generics

class FirstParameter a e | a -> e where
  getFirstParameter :: a -> e
  setFirstParameter :: e -> a -> a

  default getFirstParameter :: (Generic a, GFirstParameter (Rep a) e) => a -> e
  getFirstParameter = getFirstParameter' . from

  default setFirstParameter :: (Generic a, GFirstParameter (Rep a) e) => e -> a -> a
  setFirstParameter e = to . setFirstParameter' e . from

class GFirstParameter f e where
  getFirstParameter' :: f a -> e
  setFirstParameter' :: e -> f a -> f a

instance {-# OVERLAPPING #-} GFirstParameter (K1 i e) e where
  getFirstParameter' (K1 a) = a
  setFirstParameter' e (K1 _)  = K1 e

instance {-# OVERLAPPABLE #-} GFirstParameter (K1 i a) e where
  getFirstParameter' _ = undefined
  setFirstParameter' _ _ = undefined

instance GFirstParameter a e => GFirstParameter (M1 i c a) e where
  getFirstParameter' (M1 a) = getFirstParameter' a
  setFirstParameter' e (M1 a) = M1 $ setFirstParameter' e a

instance (GFirstParameter a e, GFirstParameter b e) => GFirstParameter (a :+: b) e where
  getFirstParameter' (L1 a) = getFirstParameter' a
  getFirstParameter' (R1 a) = getFirstParameter' a

  setFirstParameter' e (L1 a) = L1 $ setFirstParameter' e a
  setFirstParameter' e (R1 a) = R1 $ setFirstParameter' e a

instance (GFirstParameter a e, GFirstParameter b e) => GFirstParameter (a :*: b) e where
  getFirstParameter' (a :*: _) = getFirstParameter' a
  setFirstParameter' e (a :*: b) = setFirstParameter' e a :*: b

instance (GFirstParameter U1 String) where
  getFirstParameter' _ = ""
  setFirstParameter' _ e = e