{-# LANGUAGE TemplateHaskell #-}

module MonadLab.MLabParser (
   mlabParser
 ) where

import MonadLab.CommonTypes
import MonadLab.MonadLab
import Language.Haskell.TH
import MonadLab.TypeParser
import Text.ParserCombinators.Parsec hiding (State)
import Text.ParserCombinators.Parsec.Token
import Text.ParserCombinators.Parsec.Language

mlabParser :: String -> (MonadName,[Layer])
mlabParser s = case (parse monadSpecParser "" s) of
                  Left err -> error $ "MonadLab monad spec parser error " ++ show err
                  Right  r -> r 

lexer :: TokenParser ()
lexer  = makeTokenParser
	 (emptyDef { reservedNames   = ["monad"]
		   , reservedOpNames = ["=","+"]
		   });

layerSpecParser :: Parser Layer
layerSpecParser = try (
                    do{ reserved lexer "List"
                      ; return List
                      }
                  )
                  <|>
                  try (
                    do{ reserved lexer "Io"
                      ; return Io
                      }
                  )
		  <|>
		  try (
                    do{ reserved lexer "ErrorT"
                      ; t <- parens lexer (many (noneOf ")"))
                      ; n <- identifier lexer
                      ; return (ErrorT n (typeParser t))
                    }
                  )
                  <|>
                  try (
                    do{ reserved lexer "StateT"
                      ; t <- parens lexer (many (noneOf ")"))
                      ; n <- identifier lexer
                      ; return (StateT n (typeParser t))
                    }
                  )
                  <|>
                  try (
                    do{ reserved lexer "EnvT"
                      ; t <- parens lexer (many (noneOf ")"))
                      ; n <- identifier lexer
                      ; return (EnvT n (typeParser t))
                    }
                  )
                  <|>
                  try (
                    do{ reserved lexer "WriterT"
                      ; t <- parens lexer (many (noneOf ")"))
                      ; n <- identifier lexer
                      ; return (WriterT n (typeParser t))
                    }
                  )
                  <|>
                  try (
                    do{ reserved lexer "ContT"
                      ; t <- parens lexer (many (noneOf ")"))
                      ; return (ContT (typeParser t))
                    }
                  )
                  <|>
		  try (
		    do{ reserved lexer "ResT"
		      ; n <- identifier lexer
		      ; return (ResT n)
		    }
                  )
                  <?>
                  "layer spec"

monadSpecParser :: Parser (MonadName,[Layer])
monadSpecParser = do{ reserved lexer "monad"
                    ; mName <- identifier lexer
                    ; reservedOp lexer "="
                    ; layerSpecs <- sepBy layerSpecParser (reservedOp lexer "+")
                    ; eof
                    ; return (mName,layerSpecs)
                  }