{-# LANGUAGE TemplateHaskell, CPP #-}
-- |
-- Module      : Data.Express.Name.Derive
-- Copyright   : (c) 2019-2024 Rudy Matela
-- License     : 3-Clause BSD  (see the file LICENSE)
-- Maintainer  : Rudy Matela <rudy@matela.com.br>
--
-- Allows automatic derivation of 'Name' typeclass instances.
module Data.Express.Name.Derive
  ( deriveName
  , deriveNameCascading
  , deriveNameIfNeeded
  )
where

import qualified Data.Express.Name as N

import Control.Monad
import Data.Char
import Data.List
import Data.Express.Utils.TH

-- | Derives a 'N.Name' instance
--   for the given type 'Name'.
--
-- This function needs the @TemplateHaskell@ extension.
deriveName :: Name -> DecsQ
deriveName :: Name -> DecsQ
deriveName  =  Name -> (Name -> DecsQ) -> Name -> DecsQ
deriveWhenNeededOrWarn ''N.Name Name -> DecsQ
reallyDeriveName

-- | Same as 'deriveName' but does not warn when instance already exists
--   ('deriveName' is preferable).
deriveNameIfNeeded :: Name -> DecsQ
deriveNameIfNeeded :: Name -> DecsQ
deriveNameIfNeeded  =  Name -> (Name -> DecsQ) -> Name -> DecsQ
deriveWhenNeeded ''N.Name Name -> DecsQ
reallyDeriveName

-- | Derives a 'N.Name' instance for a given type 'Name'
--   cascading derivation of type arguments as well.
deriveNameCascading :: Name -> DecsQ
deriveNameCascading :: Name -> DecsQ
deriveNameCascading  =  Name -> (Name -> DecsQ) -> Name -> DecsQ
deriveWhenNeeded ''N.Name Name -> DecsQ
reallyDeriveNameCascading

reallyDeriveName :: Name -> DecsQ
reallyDeriveName :: Name -> DecsQ
reallyDeriveName Name
t  =  do
  (Type
nt,[Type]
vs) <- Name -> Q (Type, [Type])
normalizeType Name
t
  Bool
isNum <- Name
t Name -> Name -> Q Bool
`isInstanceOf` ''Num
  [d| instance N.Name $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
nt) where
        name _  =  $(String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ Bool -> String
vname Bool
isNum) |]
  where
  showJustName :: Name -> String
showJustName  =  String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a. Show a => a -> String
show
  vname :: Bool -> String
vname Bool
True   =  String
"x"
  vname Bool
False  =  (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
1 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Name -> String
showJustName Name
t

-- Not only really derive Name instances,
-- but cascade through argument types.
reallyDeriveNameCascading :: Name -> DecsQ
reallyDeriveNameCascading :: Name -> DecsQ
reallyDeriveNameCascading  =  Name -> (Name -> DecsQ) -> Name -> DecsQ
reallyDeriveCascading ''N.Name Name -> DecsQ
reallyDeriveName