{-# LANGUAGE TemplateHaskell #-}

module MonadLab.TypeParser (typeParser) where

import Data.List (nub)
import Language.Haskell.TH
import Text.ParserCombinators.Parsec hiding (token)
import Text.ParserCombinators.Parsec.Error

typeParser :: String -> Q Type
typeParser s = case (parse top "" s) of
			Left err  -> error "MonadBuilder Type Parser error"
			Right  r  -> return r 

top :: Parser Type
top = try (do
	     cxt <- context
	     token (string "=>")
	     t   <- htype
	     let ns = nub $ concatMap getVarTNames cxt ++ getVarTNames t
	     return $ ForallT ns cxt t )
  <|> try htype
  <?> "type"

context :: Parser Cxt
context = try (do 
	    c <- clas
	    return [c] )
      <|> try (do
      	    token (char '(')
	    cs <- sepBy clas (token (char ','))
	    token (char ')')
	    return cs )
      <?> "context"
	    
clas :: Parser Type
clas = try (do
	      tcl <- token qtycls
	      tv  <- token tyvar
	      let tcl' = ConT (mkName tcl)
	          tv'  = VarT (mkName tv)
	      return $ AppT tcl' tv' )
   <|> try (do
   	      tcl <- token qtycls
	      token (char '(')
	      tv  <- token tyvar
	      ts  <- many1 atype
	      token (char ')')
	      let tcl' = ConT (mkName tcl)
	          tv'  = VarT (mkName tv)
     	      return $ AppT tcl' (foldl1 AppT (tv' : ts)) )
   <?> "type class constraint"

getVarTNames :: Type -> [Name]
getVarTNames (ForallT _ _ _) = error "getVarTNames: Cannot apply getVarTNames to ForallT variant"
getVarTNames (VarT n)	     = [n]
getVarTNames (ConT _)	     = []
getVarTNames (TupleT _)	     = []
getVarTNames ArrowT	     = []
getVarTNames ListT	     = []
getVarTNames (AppT t1 t2)    = nub $ getVarTNames t1 ++ getVarTNames t2


htype :: Parser Type
htype = do
	ts <- sepBy1 btype (token (string "->"))
	return $ foldr1 arrowT ts
    <?> "type"
		where arrowT t1 t2 = AppT (AppT ArrowT t1) t2

btype :: Parser Type
btype = do
	ts <- many1 atype
	return $ foldl1 AppT ts
    <?> "type"
 

atype :: Parser Type
atype = try (token gtycon)
    <|> try (do
    		n <- token tyvar
		return $ VarT (mkName n) )
    <|> try (do
    		token (char '(')
    		ts <- sepBy1 htype (token (char ','))
		token (char ')')
		if length ts > 1
			then return $ foldl AppT (TupleT (length ts)) ts
			else return $ head ts )
    <|> try (do
    		token (char '[')
		t <- htype
		token (char ']')
		return $ AppT ListT t )
    <?> "type"		
		
   

gtycon :: Parser Type
gtycon = try (do
	 	n <- qtycon
		return $ ConT (mkName n) )
     <|> try (do
	 	token (char '(')
		token (char ')')
		return $ ConT ''() )
     <|> try (do
		token (string "[]")
		return ListT )
     <|> try (do
	 	token (char '(')
		token (string "->")
		token (char ')')
		return ArrowT )
     <|> try (do
	 	token (char '(')
		commas <- many1 (token (char ','))
		token (char ')')
		return $ TupleT (length commas + 1) )
     <?> "type constructor"


modPrefix :: Parser String
modPrefix = do
		m <- modid
		char '.'
		return (m ++ ".")
	<?> ""

qtycon :: Parser String
qtycon = do
	 ms <- many (try modPrefix)
	 tc <- tycon
	 return (concat ms ++ tc)
     <?> ""

qtycls :: Parser String
qtycls = do
	 ms  <- many (try modPrefix)
	 tcl <- tycls
	 return (concat ms ++ tcl)
     <?> ""

token :: Parser a -> Parser a
token p = do
	  a <- p
	  spaces
	  return a
      <?> ""

modid, tycls, tycon, tyvar :: Parser String
modid = conid <?> "module identifier"
tycls = conid <?> "type class"
tycon = conid <?> "type constructor"
tyvar = varid <?> "type variable"

varid :: Parser String
varid = do
	c <- small
	cs <- many (small <|> large <|> digit <|> char '\'')
	return (c:cs)
	<?> "variable identifier"

conid :: Parser String
conid = do
	c <- large
	cs <- many (small <|> large <|> digit <|> char '\'')
	return (c:cs)
	<?> "constructor identifier"
	
small = char '_' <|> lower <?> ""
large = upper <?> ""




run x = runQ x >>= putStrLn . pprint