-- |
-- Module      : Language.Haskell.TH.Name.CamelCase
-- Copyright   : 2013-2018 Kei Hibino, 2015 Shohei Murayama
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module provides camelcased 'Name' for Template Haskell
module Language.Haskell.TH.Name.CamelCase (
  -- * Types to wrap 'Name'
  -- $nameTypes
  ConName (ConName, conName), toConName,
  VarName (VarName, varName), toVarName,

  -- * Functions to make camel-cased names
  -- $makeNames
  conCamelcaseName, varCamelcaseName,

  -- * Functions to generate haskell template from names
  -- $makeTemplates
  toTypeCon, toDataCon,

  toVarExp, toVarPat,
  ) where

import Data.Char (toUpper, toLower, isLetter, isDigit)
import Data.Set (Set, fromList, member)
import Language.Haskell.TH
  (Name, mkName, TypeQ, conT, ExpQ, conE, varE, PatQ, varP)

capitalize :: String -> String
capitalize :: [Char] -> [Char]
capitalize (Char
c:[Char]
cs) = Char -> Char
toUpper Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
cs
capitalize [Char]
""     = [Char]
""

unCapitalize :: String -> String
unCapitalize :: [Char] -> [Char]
unCapitalize (Char
c:[Char]
cs) = Char -> Char
toLower Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
cs
unCapitalize [Char]
""     = [Char]
""

-- Adds a _ to the identifier which does not start with a letter or an
-- underscore.
letterStart :: String -> String
letterStart :: [Char] -> [Char]
letterStart (Char
c:[Char]
cs) | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'   Bool -> Bool -> Bool
||
                     Char -> Bool
isLetter Char
c    = Char
cChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
cs
                   | Bool
otherwise     = Char
'_'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Char
cChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
cs
letterStart [Char]
""                     = [Char]
""

-- Only letters, digits, underscores and single quotes are allowed in an
-- identifier.
allowedChars :: String -> String
allowedChars :: [Char] -> [Char]
allowedChars [Char]
cs = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
replaceUnallowed [Char]
cs
  where
    replaceUnallowed :: Char -> Char
replaceUnallowed Char
c | Char -> Bool
isLetter Char
c    Bool -> Bool -> Bool
||
                         Char -> Bool
isDigit  Char
c    Bool -> Bool -> Bool
||
                         Char
c Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
"_'"    = Char
c
                       | Bool
otherwise        = Char
'_'

-- | rename the string that equals to reserved identifiers.
rename :: String -> String
rename :: [Char] -> [Char]
rename [Char]
cs | [Char]
cs [Char] -> Set [Char] -> Bool
forall a. Ord a => a -> Set a -> Bool
`member` Set [Char]
reservedIds = [Char]
cs [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_"
          | Bool
otherwise = [Char]
cs
{-# INLINE rename #-}

-- | All reserved identifiers. Taken from section 2.4 of the 2010 Report.
reservedIds :: Set String
reservedIds :: Set [Char]
reservedIds = [[Char]] -> Set [Char]
forall a. Ord a => [a] -> Set a
fromList [ [Char]
"case", [Char]
"class", [Char]
"data", [Char]
"default", [Char]
"deriving"
                       , [Char]
"do", [Char]
"else", [Char]
"foreign", [Char]
"if", [Char]
"import", [Char]
"in"
                       , [Char]
"infix", [Char]
"infixl", [Char]
"infixr", [Char]
"instance", [Char]
"let"
                       , [Char]
"module", [Char]
"newtype", [Char]
"of", [Char]
"then", [Char]
"type", [Char]
"where"
                       , [Char]
"_" ]
{-# INLINE reservedIds #-}

{- $nameTypes
Wrap 'Name' to distinguish constructor names and variable names.
-}

-- | Type to wrap constructor\'s 'Name'.
newtype ConName = ConName { ConName -> Name
conName :: Name {- ^ Get wrapped 'Name' -} }

-- | Make constructor name from 'String'.
toConName :: String -> ConName
toConName :: [Char] -> ConName
toConName =  Name -> ConName
ConName (Name -> ConName) -> ([Char] -> Name) -> [Char] -> ConName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Name
mkName ([Char] -> Name) -> ([Char] -> [Char]) -> [Char] -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
rename ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
capitalize ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
             [Char] -> [Char]
allowedChars ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
letterStart

-- | Type to wrap variable\'s 'Name'.
newtype VarName = VarName { VarName -> Name
varName :: Name {- ^ Get wrapped 'Name' -} }

-- | Make variable name from 'String'.
toVarName :: String -> VarName
toVarName :: [Char] -> VarName
toVarName =  Name -> VarName
VarName (Name -> VarName) -> ([Char] -> Name) -> [Char] -> VarName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Name
mkName ([Char] -> Name) -> ([Char] -> [Char]) -> [Char] -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
rename ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
unCapitalize ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
             [Char] -> [Char]
allowedChars ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
letterStart

-- | 'Char' set used from camel-cased names.
nameChars :: String
nameChars :: [Char]
nameChars =  Char
'\'' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char
'0' .. Char
'9'] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char
'A' .. Char
'Z'] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++  [Char
'a' .. Char
'z']

-- | Split into chunks to generate camel-cased 'String'.
splitForName :: String -> [String]
splitForName :: [Char] -> [[Char]]
splitForName [Char]
str
  | [Char]
rest [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [] = [Char]
tk [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char] -> [[Char]]
splitForName ([Char] -> [Char]
forall a. [a] -> [a]
tail [Char]
rest)
  | Bool
otherwise  = [[Char]
tk]
  where
    ([Char]
tk, [Char]
rest) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
nameChars) [Char]
str

{- $makeNames
Make camel-cased names.
-}

-- | Convert into camel-cased 'String'.
--   First 'Char' of result is upper case.
camelcaseUpper :: String -> String
camelcaseUpper :: [Char] -> [Char]
camelcaseUpper =  ([Char] -> [Char]) -> [[Char]] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Char] -> [Char]
capitalize ([[Char]] -> [Char]) -> ([Char] -> [[Char]]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
splitForName

-- | Make camel-cased constructor name from 'String'.
conCamelcaseName :: String -> ConName
conCamelcaseName :: [Char] -> ConName
conCamelcaseName =  [Char] -> ConName
toConName ([Char] -> ConName) -> ([Char] -> [Char]) -> [Char] -> ConName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
camelcaseUpper

-- | Make camel-cased variable name from 'String'.
varCamelcaseName :: String -> VarName
varCamelcaseName :: [Char] -> VarName
varCamelcaseName =  [Char] -> VarName
toVarName ([Char] -> VarName) -> ([Char] -> [Char]) -> [Char] -> VarName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
camelcaseUpper

{- $makeTemplates
Make haskell templates from names.
-}

-- | Make type constructor 'TypeQ' monad from constructor name type.
toTypeCon :: ConName -> TypeQ
toTypeCon :: ConName -> TypeQ
toTypeCon =  Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> TypeQ) -> (ConName -> Name) -> ConName -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConName -> Name
conName

-- | Make data constructor 'ExpQ' monad from constructor name type.
toDataCon :: ConName -> ExpQ
toDataCon :: ConName -> ExpQ
toDataCon =  Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
conE (Name -> ExpQ) -> (ConName -> Name) -> ConName -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConName -> Name
conName

-- | Make variable 'ExpQ' monad from variable name type.
toVarExp :: VarName -> ExpQ
toVarExp :: VarName -> ExpQ
toVarExp =  Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> ExpQ) -> (VarName -> Name) -> VarName -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarName -> Name
varName

-- | Make pattern 'PatQ' monad from variable name type.
toVarPat :: VarName -> PatQ
toVarPat :: VarName -> PatQ
toVarPat =  Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
varP (Name -> PatQ) -> (VarName -> Name) -> VarName -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarName -> Name
varName