module Pinchot.Names where
import Control.Monad.Trans.Class (lift)
import qualified Control.Monad.Trans.State as St
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Language.Haskell.TH as T
nameT :: T.Name
nameT = T.mkName "t"
nameA :: T.Name
nameA = T.mkName "a"
nameR :: T.Name
nameR = T.mkName "r"
typeT :: T.TypeQ
typeT = T.varT nameT
typeA :: T.TypeQ
typeA = T.varT nameA
typeR :: T.TypeQ
typeR = T.varT nameR
tyVarBndrT :: T.TyVarBndr
tyVarBndrT = T.PlainTV nameT
tyVarBndrA :: T.TyVarBndr
tyVarBndrA = T.PlainTV nameA
tyVarBndrR :: T.TyVarBndr
tyVarBndrR = T.PlainTV nameR
productionsStr :: String
productionsStr = "Productions"
productions :: T.Name
productions = T.mkName productionsStr
recordName :: String -> T.Name
recordName n = T.mkName $ "a'" ++ n
qualRecordName :: Qualifier -> String -> String
qualRecordName q s = quald q ("a'" ++ s)
newtype Namer a = Namer (St.StateT (Map String T.Name) T.Q a)
deriving (Functor, Applicative, Monad)
liftQ :: T.Q a -> Namer a
liftQ = Namer . lift
namerNewName :: Namer T.Name
namerNewName = Namer $ lift (T.newName "_namerNewName")
runNamer :: Namer a -> T.Q a
runNamer (Namer n) = fmap fst $ (St.runStateT n) Map.empty
getName :: String -> Namer T.Name
getName str = Namer $ do
names <- St.get
case Map.lookup str names of
Just n -> return n
Nothing -> do
new <- lift $ T.newName ("_getName_" ++ str)
let newMap = Map.insert str new names
St.put newMap
return new
lookupValueName :: String -> T.Q T.Name
lookupValueName str = do
mayName <- T.lookupValueName str
case mayName of
Nothing -> fail $ "name not found: " ++ str
Just r -> return r
lookupTypeName :: String -> T.Q T.Name
lookupTypeName str = do
mayName <- T.lookupTypeName str
case mayName of
Nothing -> fail $ "name not found: " ++ str
Just r -> return r
type Qualifier = String
quald
:: Qualifier
-> String
-> String
quald qual suf
| null qual = suf
| otherwise = (qual ++ '.':suf)