module Parse.ParseI (
                ParseI(..)
              , parseInterface1
              , parseInterface2
              , parseInterface3
              , parseInterface4
              , parseUntilNeed
              ) where

import Util.Extra(pair,triple,noPos)
import Parse.Lex
import Parse.Lexical
import Syntax
--import MkSyntax(mkDeclClass)
import Parse.ParseLib
import Parse.ParseLex
import Parse.Parse2
import TokenId(tNEED,tinterface,tNHCInternal)
import PreImp
import ImportState(ImportState)
import Building (Compiler(..),compiler)

data ParseI st tid declneed rest =
          ParseEof  st
        | ParseNext st Bool tid  rest   -- true if visible
        | ParseNeed st declneed rest

parseAnnotVar :: Parser (Maybe Int) [PosToken] c
parseAnnotVar =
   (\(_,LitInt Boxed i) -> Just i) `parseChk` lannot `ap` int `chk` rannot 

parseAnnotType :: Parser (Int, Bool) [PosToken] c
parseAnnotType =
   (\(_,LitInt Boxed i) unboxed -> (i,unboxed)) `parseChk` lannot `ap` int
                                                    `ap` optBang `chk` rannot 

parseAnnotNewType :: Parser Bool [PosToken] c
parseAnnotNewType =
   lannot `revChk` optBang `chk` rannot 

optBang :: Parser Bool [PosToken] b
optBang = True `parseChk` bang
              `orelse`
          parse False

optSemi :: Parser () [PosToken] b
optSemi = () `parseChk` semi
                `orelse`
           parse ()

parseNeedList :: Parser [[TokenId]] [(Pos, Lex, LexState, [PosTokenPre])] c
parseNeedList =
     many ( ((:[]).snd) `parseAp`  (conid `orelse` varid)
               `orelse`
            (map snd :: ([(a,b)] -> [b])) `parseChk` lit L_LCURL
                      `apCut` many  (conid `orelse` varid) `chkCut` lit L_RCURL)

parseNeedAnnot :: Parser (Maybe [[TokenId]]) [PosToken] b
parseNeedAnnot =
     Just `parseChk` optSemi `chk` lannot `chk` lit (L_ACONID tNEED)
                                      `apCut`  parseNeedList `chk` rannot
        `orelse`
     parse Nothing


parseInterface1 :: Parser
                       (TokenId,
                        [ImpDecl TokenId],
                        [(InfixClass TokenId, Int, [FixId TokenId])],
                        [PosToken])
                       [PosToken]
                       c
parseInterface1 =
    (\(pos,modid) imports fixdecls rest -> (modid,imports,fixdecls,rest))
                `parseChk` k_interface `apCut` bigModId
                `chkCut` lit L_where `chkCut` lcurl
                `apCut` parseImpDecls
                `apCut` parseFixDecls
                `apCut` parseRest

parseInterface2 :: ImportState
                   -> HideDeclIds
                   -> Parser (ImportState, Maybe [[TokenId]], [PosToken]) [PosToken] c
parseInterface2 st hideFun = triple `parseAp` parseITopDecls st [] hideFun
                                        `ap` parseNeedAnnot `ap` parseRest

parseEof :: Parser (Maybe a) [PosToken] c
parseEof = Nothing `parseChk` optSemi `chk` rcurl


parseInterface3 :: ImportState
                   -> [[TokenId]]
                   -> HideDeclIds
                   -> Parser
                          (ParseI ImportState (Pos, TokenId) (Maybe [[TokenId]]) [PosToken])
                          [PosToken]
                          b
parseInterface3 st needs hideFun =
  ParseEof st `parseChk` parseEof
    `orelse`
  ParseNext st `parseChk` k_interface `apCut` optBang `ap` bigModId
                                                              `apCut` parseRest
    `orelse`
  ParseNeed `parseAp` parseITopDecls st needs hideFun `apCut` parseNeedAnnot
                                                              `apCut` parseRest

parseInterface4 :: ImportState
                   -> HideDeclIds
                   -> Parser
                          (ParseI ImportState (Pos, TokenId) declneed [PosToken])
                          [PosToken]
                          c
parseInterface4 st hideFun =
  parseITopDecls st [] hideFun `into`
        \st -> ParseEof st `parseChk` parseEof
                   `orelse`
               ParseNext st `parseChk` k_interface  `apCut` optBang
                                               `ap` bigModId `apCut` parseRest

parseITopDecls :: ImportState
                  -> [[TokenId]]
                  -> HideDeclIds
                  -> Parser ImportState [PosToken] c
parseITopDecls st needs hideFuns =
     optSemi `revChk` iterateSemi0 st semi
                                   (\st -> parseITopDecl st needs hideFuns)

iterateSemi0 :: a1
                -> Parser a i b
                -> (a1 -> Parser a1 i b)
                -> Parser a1 i b
iterateSemi0 st s p = iterateSemi st s p
                        `orelse`
                      parse st

iterateSemi :: a
               -> (Parser a1 i b)
               -> (a -> Parser a i b)
               -> Parser a i b
iterateSemi st s p = p st `intoCut` (\st -> semiIterate st s p) 

semiIterate :: a
               -> Parser a1 i b
               -> (a -> Parser a i b)
               -> Parser a i b
semiIterate st s p = s `revChk` iterateSemi st s p
                        `orelse`
                     parse st

parseITopDecl :: ImportState -> [[TokenId]] -> HideDeclIds
              -> Parser ImportState [PosToken] c
parseITopDecl st needs hideFuns =
  cases
      [ (L_type, \pos ->
                 hType hideFuns st `parseAp` parseAnnotType
                             `ap` parseSimple `chkCut` equal `apCut` parseType)
      , (L_newtype, \pos ->
                    (hData hideFuns st . Left)
                           `parseAp` parseAnnotNewType `ap` parseContexts
                           `ap` parseSimple `apCut`
                               ( equal `revChk` someSep pipe parseConstr
                                   `orelse`
                                 parse [])
                           `ap` parse needs `apCut` parseDeriving)
      , (L_data, \pos ->
                 hDataPrim hideFuns st `parseChk` k_primitive 
                                        `apCut` conid `chk` equal
                                                      `apCut` intPrim
                   `orelse`
                 (hData hideFuns st . Right) `parseAp` unboxed
                           `ap` parseContexts `ap` parseSimple `apCut`
                               ( equal `revChk` someSep pipe parseConstr
                                    `orelse`
                                 parse [])
                           `ap` parse needs `apCut` parseDeriving)
      , (L_class, \pos ->
                  hClass hideFuns st `parseAp` parseContexts `ap` aconid
                            `ap` some avarid `apCut`
                                 (lit L_where `revChk` lcurl
                                              `revChk` parseICSigns
                                              `chk` optSemi
                                              `chkCut` rcurl
                                       `orelse`
                                  parse [])
                            `ap` (parse needs))
      , (L_instance, \pos ->
              if compiler==Yhc then
                   hInstance hideFuns st `parseAp` aconid `chkCut` lit L_At
                                     `apCut` parseContexts
                                     `apCut` aconid `apCut` some parseInst
              else hInstance hideFuns st `parseAp` (parse (noPos,tNHCInternal))
                                     `ap` parseContexts
                                     `apCut` aconid `apCut` some parseInst )
      ]
      (hVarsType hideFuns st
           `parseAp` someSep comma (pair `parseAp` varid `ap` parseAnnotVar)
           `chkCut` coloncolon `apCut` parseContexts `apCut` parseType)

parseICSigns :: Parser [([((Pos, TokenId), Maybe Int)], [Context TokenId], Type TokenId)] [PosToken] c
parseICSigns =
    id `parseChk` optSemi `ap` manySep semi parseICSign


parseICSign :: Parser ([((Pos, TokenId), Maybe Int)], [Context TokenId], Type TokenId) [PosToken] c
parseICSign =
    triple `parseAp` someSep comma (pair `parseAp` varid `ap` parseAnnotVar)
           `chk` coloncolon `ap` parseContexts `ap` parseType



-- | Skip until next @{-# NEED list #-}@, return @(Just ([],Just need,rest))@.
-- The same type as 'parseInterface3' [No it isn't! Who wrote this module anyway?!? --SamB].
--
-- FIXME: simplify this type using the type synonyms in "Parse.ParseCore".
parseUntilNeed :: st
                  -> (ParseI st (Pos, TokenId) (Maybe [[TokenId]]) [PosToken]
                      -> [(Pos, Lex, LexState, [PosTokenPre])]
                      -> ParseError
                      -> ParseResult c [PosToken])
                  -> (ParseError -> ParseResult c [PosToken])
                  -> [(Pos, Lex, LexState, [PosTokenPre])]
                  -> ParseError
                  -> ParseResult c [PosToken]
parseUntilNeed st good bad input err =
   untilNeed input
 where
   untilNeed [] = error "Internal error in parseUntilNeed"
   untilNeed ((pos,L_EOF,_,_):input) = good (ParseEof st) input err
   untilNeed ((_,L_AVARID t,_,_):input) | t==tinterface =
       (ParseNext st `parseAp` optBang `ap` bigModId `apCut` parseRest)
       good bad input err
   untilNeed ((_,L_LANNOT,_,_):(_,L_ACONID x,_,_):input) | x == tNEED =
       ((ParseNeed st . Just) `parseAp` parseNeedList `chk` rannot
                                                      `apCut` parseRest)
       good bad input err
   untilNeed (_:input) = untilNeed input