-- |
-- 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 :: String -> String
capitalize (c :: Char
c:cs :: String
cs) = Char -> Char
toUpper Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs
capitalize ""     = ""

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

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

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

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

-- | All reserved identifiers. Taken from section 2.4 of the 2010 Report.
reservedIds :: Set String
reservedIds :: Set String
reservedIds = [String] -> Set String
forall a. Ord a => [a] -> Set a
fromList [ "case", "class", "data", "default", "deriving"
                       , "do", "else", "foreign", "if", "import", "in"
                       , "infix", "infixl", "infixr", "instance", "let"
                       , "module", "newtype", "of", "then", "type", "where"
                       , "_" ]
{-# 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 :: String -> ConName
toConName =  Name -> ConName
ConName (Name -> ConName) -> (String -> Name) -> String -> ConName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Name) -> (String -> String) -> String -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
rename (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
capitalize (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
             String -> String
allowedChars (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
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 :: String -> VarName
toVarName =  Name -> VarName
VarName (Name -> VarName) -> (String -> Name) -> String -> VarName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Name) -> (String -> String) -> String -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
rename (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
unCapitalize (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
             String -> String
allowedChars (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
letterStart

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

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

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

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

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

-- | Make camel-cased variable name from 'String'.
varCamelcaseName :: String -> VarName
varCamelcaseName :: String -> VarName
varCamelcaseName =  String -> VarName
toVarName (String -> VarName) -> (String -> String) -> String -> VarName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
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
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
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
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
varP (Name -> PatQ) -> (VarName -> Name) -> VarName -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarName -> Name
varName