{-# LANGUAGE ViewPatterns #-}

{- |

Module      :  Data.Proxy.TH.Aux
Copyright   :  (c) The University of Kansas 2011
License     :  BSD3

Maintainer  :  nicolas.frisby@gmail.com
Stability   :  experimental
Portability :  see LANGUAGE pragmas (... GHC)

A parser for simple type expressions, including kinds and excluding operators.

-}
module Data.Proxy.TH.Aux where

import Language.Haskell.TH

import Type.Spine.Kinds (trim, parseK)

import qualified Control.Arrow as Arrow
import Control.Monad (liftM, when, MonadPlus(..))

import Data.Char (isLower, isUpper)

instance MonadPlus Q where mzero = fail "mzero"; mplus = flip recover

tvb_kind (PlainTV _) = StarK
tvb_kind (KindedTV _ k) = k

unAppT (AppT f x) = Arrow.second (++ [x]) $ unAppT f
unAppT ty = (ty, [])



occT n@(nameBase -> (c : _)) | startsIdent c = VarT n
                             | otherwise = ConT n
occT _ = error "occT needs a non-empty name"

--------------------
startsIdent c = isLower c || '_' == c

startsName c = isUpper c || startsIdent c

parseIdent :: MonadPlus m => String -> m ([Type], String)
parseIdent s = do
  s <- return $ trim s
  (i, s) <- return $
    break (`notElem` "_'" ++ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']) s
  when (null i) $ fail $ "no identifier: `" ++ s ++ "'"
  return $ ([occT $ mkName i], s)

parseParen s = ($ s) $ parseParen' . trim
parseParen' ('(' : s) = do
  (ty, trim -> s) <- parseType s
  case s of
    ')' : s -> return ([foldl1 AppT ty], s)
    _ -> fail $ "expecting `)': " ++ s
parseParen' s = fail $ "expecting `(': " ++ s

parseType s = do
  (ty, s) <- parseIdent s `mplus` parseParen s
  x <- (Just `liftM` parseType s) `mplus` return Nothing
  return $ maybe (ty, s) (Arrow.first (foldl1 AppT ty :)) x

parseProxy_ :: MonadPlus m => String -> m (Type, Kind)
parseProxy_ s = parseProxy s >>= \(x, s) -> case trim s of
  "" -> return x
  _ -> fail $ "Data.Proxy.TH.Aux.parseProxy_: " ++ s

parseProxy :: MonadPlus m => String -> m ((Type, Kind), String)
parseProxy = w . trim where
  w s@((startsName -> True) : _) = do
    (foldl1 AppT -> ty, s) <- parseType s
    case trim s of
      ':' : ':' : s -> do
        (k, s) <- parseK s
        return ((ty, k), s)
      _ -> return ((ty, StarK), s)
  w s = fail $ "Data.Proxy.TH.Aux.parseProxy: " ++ s



--------------------
thProxyT_fail :: Maybe Name -> Q a
thProxyT_fail n = fail $ "thProxyT handles only applications of data/newtype and primitive type constructors" ++ case n of
  Just n -> "; " ++ show n ++ " is unsupported"
  Nothing -> ""