emgm-0.2: src/Generics/EMGM/Common/Derive/Common.hs

{-# LANGUAGE CPP                    #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Generics.EMGM.Common.Derive
-- Copyright   :  (c) 2008 Universiteit Utrecht
-- License     :  BSD3
--
-- Maintainer  :  generics@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Summary: Common types and functions used in the deriving code.
-----------------------------------------------------------------------------

module Generics.EMGM.Common.Derive.Common where

-----------------------------------------------------------------------------
-- Imports
-----------------------------------------------------------------------------

import Language.Haskell.TH
import Data.Maybe (fromMaybe)

-----------------------------------------------------------------------------
-- Types
-----------------------------------------------------------------------------

-- | Normalized form of a datatype declaration (@data@ and @newtype@)
data DT
  = DT
  { tname :: Name       -- Type name
  , tvars :: [Name]     -- Type variables
  , dcons :: [Con]      -- Data constructors
  , ncons :: [NCon]     -- Normalized data constructors
  } deriving Show

-- | Normalized form of a constructor
data NCon
  = NCon
  { cname :: Name       -- Constructor name
  , cdescr :: Name      -- 'ConDescr' declaration name
  , cargtypes :: [Type] -- Constructor argument types
  , cvars :: [Name]     -- Generated constructor variable names
  } deriving Show

-- | Modify the action taken for a given name.
data Modifier
  = ChangeTo String     -- ^ Change the syntactic name (of a type or
                        --   constructor) to the argument in the generated 'EP'
                        --   or 'ConDescr' value. This results in a value named
                        --   @epX@ or @conX@ if the argument is @\"X\"@.
  | DefinedAs String    -- ^ Use this for the name of a user-defined constructor
                        --   description instead of a generated one. The
                        --   generated code assumes the existance of @conX ::
                        --   'ConDescr'@ (in scope) if the argument is @\"X\"@.
  deriving Eq

instance Show Modifier where
  show (DefinedAs s) = s
  show (ChangeTo s)  = s

-- | List of pairs mapping a (type or constructor) name to a modifier action.
type Modifiers = [(String, Modifier)]

-----------------------------------------------------------------------------
-- General functions
-----------------------------------------------------------------------------

toMaybeString :: Maybe Modifier -> Maybe String
toMaybeString mm = mm >>= return . show

-- | Select the i-th field in an n-tuple
sel :: Int -> Int -> Q Exp
sel i _ | i < 0  = reportError $ "sel: Error! i (= " ++ show i ++ ") is not >= 0."
sel i n | i >= n = reportError $ "sel: Error! i (= " ++ show i ++ ") is not < n (= " ++ show n ++ ")."
sel i n          =
  do x <- newName "x"
     let firsts = replicate i wildP
         lasts = replicate (n - i - 1) wildP
         vars = firsts ++ varP x : lasts
         pats = [tupP vars]
         body = varE x
     lamE pats body

-- | i: initial type, f: final type, s: sum element, p: product element
mkSop
  :: (i -> [s])
  -> (s -> [p])
  -> (p -> f)
  -> f
  -> (f -> f -> f)
  -> (f -> f -> f)
  -> (s -> f -> f)
  -> i
  -> f
mkSop toSumList toProdList inject unit mkSum mkProd wrapProd =
  listCase3 (error "zero") id more . map toProd . toSumList
  where
    more = foldNested mkSum
    toProd x = wrapProd x . productize unit inject mkProd $ toProdList x

mkSopDT
  :: (Type -> f)
  -> f
  -> (f -> f -> f)
  -> (f -> f -> f)
  -> (NCon -> f -> f)
  -> DT
  -> f
mkSopDT = mkSop ncons cargtypes

foldNested :: (a -> a -> a) -> a -> [a] -> a
foldNested f = go
  where
    go b []     = b
    go b (x:xs) = f b (go x xs)

-- | Apply a function to each of 3 cases of a list: 0, 1, or > 1 elements
listCase3 :: b -> (a -> b) -> (a -> [a] -> b) -> [a] -> b
listCase3 zero one more ls =
  case ls of
    []   -> zero        -- 0 elements
    [x]  -> one x       -- 1 element
    x:xs -> more x xs   -- > 1 element

-- | Given a unit value, an injection function, and a product operator, create a
-- product form out of a list.
productize :: b -> (a -> b) -> (b -> b -> b) -> [a] -> b
productize unit inj prod = go
  where
    go = listCase3 unit inj more
    more x xs = prod (inj x) (go xs)

-- | Given a prefix string, a possible string for the type name, a name, and a
-- suffix string, create a function that appends either the type string name (if
-- it exists) or the base of the type name to the prefix.
mkFunName :: String -> Maybe String -> Name -> String -> Name
mkFunName prefix maybeMiddle name suffix = result
  where
    middle = fromMaybe (nameBase name) maybeMiddle
    result = mkName $ showString prefix . showString middle $ suffix

-- | Report an error message and fail
reportError :: String -> Q a
reportError msg = report True msg >> fail ""