{-# LANGUAGE TemplateHaskell, CPP #-}
-- |
-- Module      : Data.Express.Name.Derive
-- Copyright   : (c) 2019-2021 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 $(return nt) where
        name _  =  $(stringE $ vname isNum) |]
  where
  showJustName :: Name -> [Char]
showJustName  =  [Char] -> [Char]
forall a. [a] -> [a]
reverse ([Char] -> [Char]) -> (Name -> [Char]) -> Name -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') ([Char] -> [Char]) -> (Name -> [Char]) -> Name -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
forall a. [a] -> [a]
reverse ([Char] -> [Char]) -> (Name -> [Char]) -> Name -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Char]
forall a. Show a => a -> [Char]
show
  vname :: Bool -> [Char]
vname Bool
True   =  [Char]
"x"
  vname Bool
False  =  (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take Int
1 ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
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