module Parser(AgParser, parseProgram) where


import UU.Scanner
import UU.Scanner.GenToken
import UU.Parsing
import Opts
import Ast
import Common
import qualified Data.Sequence as Seq
import qualified Data.Map as Map
import Data.Map(Map)


type AgParser a = Parser Token a

pEnd :: AgParser Pos
pEnd = pKeyPos "end" <?> "end of layout"

pVarIdent :: AgParser Ident
pVarIdent = uncurry Ident <$> pVaridPos

pConIdent :: AgParser Ident
pConIdent = uncurry Ident <$> pConidPos

pIdentItf, pIdentAttr, pIdentChild, pIdentVisit, pIdentCon :: AgParser Ident
pIdentItf    = pConIdent <?> "itf ident"
pIdentAttr   = pVarIdent <?> "attr ident"
pIdentSem    = pVarIdent <?> "sem ident"
pIdentChild  = pVarIdent <?> "child ident"
pIdentVisit  = pVarIdent <?> "visit ident"
pIdentClause = pVarIdent <?> "clause ident"
pIdentCon    = pConIdent <?> "con ident"
pDataIdent   = pConIdent <?> "data ident"
pConstrIdent = pConIdent <?> "con ident"
pFieldIdent  = pVarIdent <?> "field ident"
pExtIdent    = pConIdent <?> "ext ident"
pTyVarIdent  = pVarIdent <?> "var ident"

pProgram :: AgParser Program
pProgram = (Program_Program . BlocksTop_Top) <$> pList_gr pBlock

pBlock :: AgParser Block
pBlock  =  Block_Itf <$> pItf
       <|> Block_Section <$> pCurly pCode
       <|> Block_Data <$> pData
       <|> Block_Type <$> pType
       <|> Block_DataSem <$> pDataSem

pCode :: AgParser Code
pCode = Code_Code <$> pList_gr pItem

pItf :: AgParser Itf
pItf = Itf_Itf
        <$> pKeyPos "itf"
        <*> pIdentItf
        <*> pList_gr pVar
        <*> pItfVisits
        <*  pEnd
        <?> "itf"

pItfVisits :: AgParser ItfVisits
pItfVisits
  = pList1_gr pItfVisit <?> "visits"

pItfVisit :: AgParser ItfVisit
pItfVisit
   = (ItfVisit_Visit
       <$> pKeyPos "visit"
       <*> pIdentVisit
       <*> opt (True <$ pKey "cyclic") False
       <*> pList_gr pVar
       <*> pList_gr pAttrInhSyn
       <?> "visit")

pAttrInhSyn :: AgParser Attr
pAttrInhSyn = (pAttrInh <|> pAttrSyn) <?> "attr"

pAttrInh :: AgParser Attr
pAttrInh = Attr_Inh <$ pKey "inh" <*> pVarIdent <* pKey "::" <*> (pTextln <?> "type") <* pEnd

pAttrSyn :: AgParser Attr
pAttrSyn = Attr_Syn <$ pKey "syn" <*> pVarIdent <* pKey "::" <*> (pTextln <?> "type") <* pEnd

pData :: AgParser Data
pData = Data_Data <$> pKeyPos "data" <*> pDataIdent <*> pList_gr pVar <*> pList_gr pCon <*> pList_gr pExt <* pEnd <?> "data"

pVar :: AgParser Var
pVar = Var_Var <$ pKeyPos "var" <*> pTyVarIdent <?> "var"

pExt :: AgParser Ext
pExt = Ext_Ext <$ pKeyPos "ext" <*> pExtIdent <?> "ext"

pCon :: AgParser Con
pCon = Con_Con <$> pKeyPos "con" <*> pConstrIdent <*> pList_gr pVar <*> pList_gr pField <?> "con"

pField :: AgParser Field
pField = pFieldIdent <**> (    (\nt fld -> Field_Field fld (FieldType_Nonterm nt)) <$ pKey ":"  <*> pDataIdent
                          <|>  (\tp fld  -> Field_Field fld (FieldType_Term tp))   <$ pKey "::" <*> (pTextln <?> "type") <* pEnd
                          ) <?> "field" 

pType :: AgParser Type
pType = Type_Alias <$> pKeyPos "type" <*> pDataIdent <* pKey ":" <*> pAliasType <*> pList_gr pVar <?> "type"

pAliasType :: AgParser AliasType
pAliasType
  =   (AliasType_Prod  <$> pParens_pCommas pDataIdent <?> "product type")
  <|> (AliasType_List  <$> pBracks pDataIdent <?> "list type")
  <|> (AliasType_Maybe <$  pKey "Maybe" <*> pDataIdent <?> "Maybe type")

pDataSem :: AgParser DataSem
pDataSem
  = DataSem_Sem <$> pKeyPos "datasem"
                <*> pIdentItf
                <*> pList_gr pVar
                <*> opt (pKey "monad" *> (Just <$> pTextln <* pEnd <?> "monad type")) Nothing
                <*> opt (True <$ pKey "cyclic") False
                <*> pList_gr pStmt
                <*> (ClausesTop_Impl <$> pList_gr pClause)
                <*  pEnd <?> "data sem"

pItem :: AgParser Item
pItem
  =   uncurry (flip Item_Plain) <$> (pTextlnPos <?> "code")
  <|> uncurry mkAttr <$> (pVaridPos <?> "attribute occurrence")
  <|> (Item_Sem <$> pKeyPos "sem"
                <*> pIdentSem
                <* pKey ":"
                <*> pIdentItf
                <*> pList_gr pVar
                <*> opt (pKey "monad" *> (Just <$> pTextln <* pEnd <?> "monad type")) Nothing
                <*> pSemVisit
                <* pEnd <?> "sem")
  <|> (Item_CoSem <$> pKeyPos "cosem"
                  <*> pIdentSem
                  <* pKey ":"
                  <*> pIdentItf
                  <*> pIdentVisit
                  <*> pList_gr pVar
                  <*> opt (pKey "monad" *> (Just <$> pTextln <* pEnd <?> "monad type")) Nothing
                  <*> pSemVisit
                  <* pEnd <?> "cosem")
  <|> Item_DataSem <$> pDataSem
  <|> (Item_Detach <$> pKeyPos "detach" <*> pIdentVisit <* pKey "of" <*> pIdentChild <* pEnd <?> "detach item")
  <|> (Item_Brackets <$> pKeyPos "{" <*> pList_gr pItem <*> pKeyPos"}" <?> "brackets")
  <?> "code item"
  where
    mkAttr s p = let (i,t) = break (\c -> c == '.' || c == ':') s
                 in Item_Attr p (Ident i p) (Ident (tail t) p)

pSemVisit :: AgParser SemVisit
pSemVisit
  = opt ( ((\pos nm cyclic chns stmts clauses ->
              SemVisit_Prependable pos nm (SemVisit_Visit pos nm cyclic chns stmts clauses))
                         <$> pKeyPos "visit" <*> pIdentVisit <*> opt (True <$ pKey "cyclic") False
                         <*> pList_gr pChn <*> pList_gr pStmt
                         <*> (ClausesTop_Impl <$> pList_gr pClause)
                         <* pEnd
                         <?> "visit")
          <|> ((\pos nm cyclic stmts clauses ->
               SemVisit_Internal pos nm cyclic stmts clauses)
                          <$> pKeyPos "internal" <*> pIdentVisit <*> opt (True <$ pKey "cyclic") False
                          <*> pList_gr pStmt
                          <*> (ClausesTop_Impl <$> pList_gr pClause)
                          <* pEnd
                          <?> "internal visit")
        ) SemVisit_Impl

pChn :: AgParser VisitAttr
pChn = VisitAttr_Chn <$ pKey "chn" <*> pVarIdent <* pKey "::" <*> (pTextln <?> "type") <* pEnd <?> "visit-local attr"

pClause :: AgParser Clause
pClause = Clause_Clause <$> pKeyPos "clause" <*> pClauseIdent <*> pList_gr pStmt <*> pSemVisit <* pEnd <?> "clause"

pClauseIdent :: AgParser Ident
pClauseIdent
  = pVarIdent <|> pConIdent <?> "clause name"

pStmt :: AgParser Stmt
pStmt
  =   ( Stmt_Eval   <$> opt (Mode_Match <$ pKey "match") Mode_Assert <*> pPat <*> pBoundCode <?> "eval stmt" )
  <|> ( Stmt_Invoke <$> pKeyPos "invoke" <*> pIdentVisit <* pKey "of" <*> pIdentChild <*> pMaybeBoundCode <?> "invoke stmt" )
  <|> ( (\p v mb -> Stmt_Attach p (maybe Nothing (const $ Just v) mb) (maybe v id mb) )
                    <$> pKeyPos "attach" <*> pIdentChild <*> pMbChild
                    <* pKey ":" <*> pIdentItf <*> pMaybeBoundCode <?> "attach stmt" )
  <|> ((\p -> Stmt_Attach p Nothing) <$> pKeyPos "child" <*> pIdentChild
                                     <* pKey ":" <*> pIdentItf <*> pMaybeBoundCode <?> "child stmt")
  <|> ( Stmt_Default True  <$> pKeyPos "default?" <*> pVarIdent <*> pMaybeBoundCode <?> "default stmt" )
  <|> ( Stmt_Default False <$> (pKeyPos "default" <|> pKeyPos "default1") <*> pVarIdent <*> pMaybeBoundCode <?> "default1 stmt")
  <|> ( Stmt_Rename <$> pKeyPos "rename" <*> pIdentChild <*> pList_gr pRename <?> "rename stmt")
  <?> "statement"

pRename :: AgParser Rename
pRename = Rename_Rename <$> pIdentAttr <* pKey "to" <*> pIdentAttr

pMbChild :: AgParser (Maybe Ident)
pMbChild = opt (Just <$ pKey "of" <*> pIdentChild) Nothing

pMaybeBoundCode :: AgParser MaybeBoundCode
pMaybeBoundCode
  = opt (Just <$> pBoundCode) Nothing

pBoundCode :: AgParser BoundCode
pBoundCode
  =   BoundCode_Code Bind_Fun      <$> pKeyPos "="  <*> pCode <* pEnd
  <|> BoundCode_Code Bind_Monadic  <$> pKeyPos "<-" <*> pCode <* pEnd

pPat :: AgParser Pat
pPat = pChainr_gr (Pat_Cons <$ pKey ":") pPatCon

pPatCon :: AgParser Pat
pPatCon = pIdentCon <**> (   (Pat_Con <$$> pList_gr pPatBase <?> "con pattern")
                         <|> ((pKey "." *> pIdentCon <* pKey "@" <**> Pat_AttrCon <$$> pIdentChild) <?> "attr con")
                         )
        <|> pPatBase

pPatBase :: AgParser Pat
pPatBase
  =   Pat_Underscore <$> pKeyPos "_"
  <|> Pat_Attr <$> pIdentChild <* pKey "." <*> pIdentAttr
  <|> Pat_Attr <$> pIdentChild <* pKey ":" <*> pIdentAttr  -- should actually check to only parse these in case of javascript
  <|> Pat_Tup <$> pParens_pCommas pPat
  <|> Pat_List <$> pBracks_pCommas pPat
  <?> "simple pattern"


--
-- Run parser
--

parseProgram :: Opts -> Pos -> [Token] -> Either String Program
parseProgram opts pos tks
  = parseTokens opts pos pProgram tks

parseTokens :: Opts -> Pos -> AgParser a -> [Token] -> Either String a
parseTokens opts pos p tks
  = if null msgs
    then final `seq` Right v
    else Left $ toError opts pos $ head msgs
  where
    steps = UU.Parsing.parse p tks
    msgs  = getMsgs steps
    (Pair v final) = evalSteps steps

toError :: Opts -> Pos -> Message Token (Maybe Token) -> String
toError opts pos (Msg exp mtok _)
  = show p ++ ": " ++ m ++ ". Expecting " ++ show exp
  where
    p = case mtok of
          Nothing -> pos
          Just t  -> position t
    m = case mtok of
          Nothing -> "end of file"
          Just tok -> case tok of
                        Reserved str _         -> "symbol " ++ show str
                        ValToken TkError val _ -> "unrecognized token " ++ show val
                        ValToken tp val _      -> let descr = if verbose opts then show tp ++ " " else ""
                                                  in descr ++ show val