module Parser
 (
 parseIdList,
 TokenType(..),
 expectNormal,
 Parser, Parse(..),
 note, failWith, failError, failEnd, failEmpty,
 on, onOK, onError, onEnd, onEmpty, onAnyOK, onAnyError, onAnyEnd, onAnyEmpty,
 instead, insteadOK, insteadError, insteadEnd, insteadEmpty,
 insteadNonOK, insteadAnyOK, insteadAnyError, insteadAnyEnd, insteadAnyEmpty,
 showStruct, structParser, eval,
 expect, look, expectType, lookType, expectICase, expectEof,
 iterateParserSep, iterateParser,
 localPhase, setPhase,
 skipTo, getPos, showPosition,
 normListParser, separator, run,
 Ass(..),unAss
 ) where

import Char
import FiniteMap
import Set
import Monad
import qualified List
import Maybe

-- Set -- Show, Read

instance (Show a)=>Show (Set a) where
 showsPrec p=showList . setToList

instance (Parse a,Ord a)=>Parse (Set a) where
 parser p=
   do
    list<-listParser p
    return $ mkSet list

-- FiniteMap -- Show

instance (Show a,Show b)=>Show (FiniteMap a b) where
 showsPrec p l=showList $ map (uncurry Ass) (fmToList l)

-- Parsing simple states
parseIdList::(Show a)=>[a]->Parser a
parseIdList=msum . map parseId

parseId::(Show a)=>a->Parser a
parseId a=
 do
  expect $ TokId (show a)
  return a

-- Parsing anything that can form a string
ul2sp::String->String
ul2sp=map (\x->if x=='_' then ' ' else x)

expectNormal::Parser String
expectNormal=
 do
  TokStr r<-expectType (TokStr "")
  return r
 `mplus`
 do
  TokNum r<-expectType (TokNum 0)
  return $ show r
 `mplus`
 do
  TokId r<-expectType (TokId "")
  return $ ul2sp r

-- Token

data TokenType=TokId String
              |TokNum Int
              |TokOp String
              |TokSep String
              |TokStr String
              |TokLexError String deriving (Eq,Show)
data Token=Token {tokenLine::Int,tokenType::TokenType} deriving (Eq)

iCaseSameString::String->String->Bool
iCaseSameString a b=and $ zipWith (\x y->toLower x==toLower y) a b

iCaseSame::TokenType->TokenType->Bool
iCaseSame (TokId a) (TokId b)     = iCaseSameString a b
iCaseSame (TokNum a) (TokNum b)   = a==b
iCaseSame (TokOp a) (TokOp b)     = iCaseSameString a b
iCaseSame (TokSep a) (TokSep b)   = iCaseSameString a b
iCaseSame (TokStr a) (TokStr b)   = iCaseSameString a b
iCaseSame (TokLexError a) (TokLexError b) = a==b
iCaseSame _ _                     = False

--- Show

instance Show Token where
 showsPrec p (Token line typ) app=show typ++app
 showList l app=(showTokList 0 l)++app

showTokList::Int->[Token]->String
showTokList _ []="\n"
showTokList aline (Token line val:rest)
 | aline == line = " | "++show val++showTokList aline rest
 | otherwise     = "\n"++show line++" : "++show val++showTokList line rest

-- Parser

data Status=StatusOK
           |StatusError
           |StatusEmpty
           |StatusEnd
           deriving (Eq,Show)


data State=State {stStatus::Status,stPosition::[Token],stErrors::[String],stPhase::Int}
           deriving (Show)

newState::[Token]->State
newState pos=(State StatusOK pos [] 0)

data Parser a=Parser (State->(State,Maybe a))

instance Monad Parser where
 Parser f >>= s = Parser (\inpState->
   let (fState,dat)=f inpState in
     case stStatus fState of
       StatusOK ->
         case s (fromJust dat) of
          Parser p->p fState
       _ ->(fState,Nothing)
   )
 return x=Parser (\state->(state{stStatus=StatusOK},Just x))
 fail s=Parser (\state->
   let pos=stPosition state
       err=stErrors state
       formErr="Parse error ( "++s++" ) at "++showPosition pos
      in
       (state{stStatus=StatusError,stErrors=(formErr:err)},Nothing)
   )

note::String->Parser ()
note what=Parser (\state->
   let err=stErrors state
    in (state{stStatus=StatusOK,stErrors=what:err},Just ())
   )

failWith::Status->Parser a
failWith status=Parser (\state->(state{stStatus=status},Nothing))

failError=failWith StatusError
failEnd=failWith StatusEnd
failEmpty=failWith StatusEmpty

on::(Status->Bool)->(Int->Bool)->Parser a->Parser a->Parser a
on cOnStatus cOnPhase (Parser p1) (Parser p2)=Parser (\state->
  let res1=p1 state
      res2=p2 $ fst res1
   in
    if cOnStatus (stStatus $ fst res1) && cOnPhase (stPhase $ fst res1)
      then res2
      else res1
  )

onOK=on (==StatusOK)
onError=on (==StatusError)
onEnd=on (==StatusEnd)
onEmpty=on (==StatusEmpty)

onAnyOK=onOK (\x->True)
onAnyError=onError (\x->True)
onAnyEnd=onEnd (\x->True)
onAnyEmpty=onEmpty (\x->True)

instead::(Status->Bool)->(Int->Bool)->Parser a->Parser a->Parser a
instead cOnStatus cOnPhase (Parser p1) (Parser p2)=Parser (\state->
  let res1=p1 state
      res2=p2 state
   in
    if cOnStatus (stStatus $ fst res1) && cOnPhase (stPhase $ fst res1)
      then res2
      else res1
  )

insteadOK=instead (==StatusOK)
insteadError=instead (==StatusError)
insteadEnd=instead (==StatusEnd)
insteadEmpty=instead (==StatusEmpty)

insteadNonOK=instead (/=StatusOK) (\x->True)
insteadAnyOK=insteadOK (\x->True)
insteadAnyError=insteadError (\x->True)
insteadAnyEnd=insteadEnd (\x->True)
insteadAnyEmpty=insteadEmpty (\x->True)

instance MonadPlus Parser where
 mzero=Parser (\state->(state{stStatus=StatusError},Nothing))
 mplus=insteadAnyError

setPhase::Int->Parser ()
setPhase to=Parser (\state->(state{stStatus=StatusOK,stPhase=to},Just ()))

getPhase::Parser Int
getPhase=Parser (\state->(state{stStatus=StatusOK},Just $ stPhase state))

localPhase::Parser a->Parser a
localPhase p=Parser (\state->
  let phase=stPhase state
      Parser pars = setPhase 0 >> p
      (nstate,ret) = pars state
      rstate=nstate{stPhase=phase}
   in (rstate,ret)
  )


iterateParser::Parser a->Parser [a]
iterateParser=iterateParserSep (return ())

iterateParserSepB::Parser b->Parser a->Parser [a]
iterateParserSepB sep p=
 localPhase
  (
  do
   setPhase 0
   sep
   setPhase 1
   iterateParserSep sep p
  `onEndSep`
   return []
  `onSepSkipped`
   iterateParserSep sep p
  )
 where
  onEndSep=onEnd (==0)
  onSepSkipped=onEmpty (==0)

iterateParserSep::Parser b->Parser a->Parser [a]
iterateParserSep sep p=
 localPhase
  (
  do
   setPhase 0
   h<-p
   setPhase 1
   t<-iterateParserSepB sep p
   return (h:t)
  `onEndReached`
   return []
  `onItemSkipped`
   iterateParserSepB sep p
  )
 where
  onEndReached=onEnd (==0)
  onItemSkipped=onEmpty (==0)

separator::TokenType->TokenType->Parser ()
separator by end=
 do
  expect by
  return ()
 `mplus`
 do
  look end
  failEnd

step::Parser TokenType->Parser TokenType->TokenType->Parser TokenType
step lk next what=
 do
  tok<-lk
  if tok==what
   then next
   else fail ("unexpected token " ++ show tok)

stepI::Parser TokenType->Parser TokenType->TokenType->Parser TokenType
stepI lk next what=
 do
  tok<-lk
  if tok `iCaseSame` what
   then next
   else fail ("unexpected token " ++ show tok)

expect=step lookToken takeToken
expectICase=stepI lookToken takeToken
look=step lookToken lookToken
lookICase=stepI lookToken lookToken

sameType::TokenType->TokenType->Bool
sameType TokId {} TokId {}=True
sameType TokNum {} TokNum {}=True
sameType TokOp {} TokOp {}=True
sameType TokSep {} TokSep {}=True
sameType TokStr {} TokStr {}=True
sameType _ _=False

stepType::Parser TokenType->Parser TokenType->TokenType->Parser TokenType
stepType lk next what=
 do
  tok<-lk
  if sameType tok what
   then next
   else fail ("unexpected token " ++ show tok)

expectType=stepType lookToken takeToken
lookType=stepType lookToken lookToken

takeToken::Parser TokenType
takeToken=Parser (\state->
 case stPosition state of
  (Token _ h:t)->(state{stStatus=StatusOK,stPosition=t},Just h)
  []->(state{stStatus=StatusError},Nothing)
 )

lookToken::Parser TokenType
lookToken=Parser (\state->
 case stPosition state of
  (Token _ h:_)->(state{stStatus=StatusOK},Just h)
  []->(state{stStatus=StatusError},Nothing)
 )

skipTo::Parser b->Parser ()
skipTo kon=
 do
  kon
  return ()
 `mplus`
 do
  takeToken
  skipTo kon

currentLine::Parser Int
currentLine=Parser (\state->
 case stPosition state of
  (Token line _:_)->(state{stStatus=StatusOK},Just line)
  []->(state{stStatus=StatusEnd},Nothing)
 )

getPos::Parser [Token]
getPos=Parser (\state->(state{stStatus=StatusOK},Just $ stPosition state))

push::TokenType->Parser ()
push what=Parser (\state->
   let pos=stPosition state
       tok=Token (-1) what
    in (state{stStatus=StatusOK,stPosition=tok:pos},Just ())
   )

expectEof::Parser ()
expectEof=Parser (\state->
 case stPosition state of
  []->(state{stStatus=StatusOK},Just ())
  _->(state{stStatus=StatusError},Nothing)
 )

-- Parse

class Parse a where
 parser::Int->Parser a
 listParser::Int->Parser [a]
 listParser p=iterateParser (parser p)

-- Ass

data Ass k v=Ass k v

--- Show

unAss::Ass k v->(k,v)
unAss (Ass k v)=(k,v)

instance (Show k,Show v)=>Show (Ass k v) where
 showsPrec p (Ass k v) rest=show k++" -> "++show v++rest
 showList items=(concat ws ++)
  where
   ws=List.intersperse "\n" $ map show items

--- Parse

instance (Parse k,Parse v)=>Parse (Ass k v) where
 parser p=
  do
   x<-parser 0
   expect (TokOp "->")
   y<-parser 0
   return $ Ass x y
  `mplus`
  do
   expectEof
   failEnd

-- Struct

--- Show

quoteChar::Char->String
quoteChar '\\'="\\\\"
quoteChar '\n'="\\n"
quoteChar z=[z]

quote::String->String
quote=concatMap quoteChar

showItem::(String,String)->String
showItem (name,value)=
 name++"="++quote(value)++"\n"

showStruct::String->[(String,String)]->String
showStruct blockName items=
 "["++blockName++"]\n\n"++concatMap showItem items++"\n"

--- Parser

type Dict=FiniteMap String String

restOfLine::Parser String
restOfLine=
 do
  expectEof
  return ""
 `mplus`
 do
  line<-currentLine
  ret<-restOfLineN line
  return ret

tokToStr::TokenType->String
tokToStr tok=
 case tok of
  TokNum x -> show x
  TokStr x -> "\"" ++ quote x ++ "\""
  TokSep x -> x
  TokId x  -> x
  TokOp x  -> x

restOfLineN::Int->Parser String
restOfLineN line=
 do
  expectEof
  return ""
 `mplus`
 do
  aline<-currentLine
  if aline>line
   then return ""
   else do
         tok<-takeToken
         rest<-restOfLineN line
         if rest==""
          then return $ tokToStr tok
          else return (tokToStr tok ++ " " ++ rest)

itemParser::Parser (String,String)
itemParser=
 do
  look (TokSep "[")
  failEnd
 `mplus`
 do
  expectEof
  failEnd
 `mplus`
 do
  TokId name<-expectType (TokId "")
  expect (TokOp "=")
  value<-restOfLine
  return (name,value)
 `mplus`
 do
  pos<-getPos
  note $ showPosition pos ++ " skipped"
  restOfLine
  failEmpty

itemsGatherer::Parser Dict
itemsGatherer=
 do
  pairs<-iterateParser itemParser
  return $ listToFM pairs

data DataStruct=DataStruct String Dict deriving (Show)

structParser::String->[(String,Bool)]->Parser [Maybe String]
structParser blockName items=
 do
  DataStruct name itemDict<-rawStructParser
  unless (name == blockName)
    (note $ "Wrong id " ++ name ++", assuming " ++ blockName)
  (values,rest)<-foldM lookupItem ([],itemDict) items
  unless (isEmptyFM rest)
    (note $ "Extra values " ++ show rest)
  return $ reverse values
 where
  lookupItem (values,dict) (item,mandatory)=
   case (lookupFM dict item,mandatory) of
    (Nothing,True) ->
     do
      note $ "Mandatory field " ++ item ++ " is not present, assuming value \"\""
      return (Just "":values,dict)
    (Nothing,False) ->
     return (Nothing:values,dict)
    (Just value,_) ->
     return (Just value:values,delFromFM dict item)

rawStructParser::Parser DataStruct
rawStructParser=
 localPhase
  (
  do
   setPhase 0
   expect (TokSep "[")
   setPhase 1
   TokId name<-expectType (TokId "")
   setPhase 2
   expect (TokSep "]")
   setPhase 3
   values<-itemsGatherer
   return $ DataStruct name values
  `unexpEnd`
  do
   note "Unexpected end"
   failEnd
  `errBeg`
  do
   expectEof
   failEnd
  `errBeg`
  do
   note "Skipping to next ["
   skipTo $ ((look $ TokSep "[") >> return ()) `mplus` expectEof
   failEmpty
  `wrongId`
  do
   note $ "Wrong id, assuming \"\""
   takeToken
   push (TokId "")
   push (TokSep "[")
   rawStructParser
  `errCl`
  do
   note $ "] inserted"
   expect (TokSep "[")
   name<-expectType (TokId "")
   push (TokSep "]")
   push name
   push (TokSep "[")
   rawStructParser
  )
 where
  unexpEnd=onEnd (/=0)
  errBeg=onError (==0)
  wrongId=onError (==1)
  errCl=insteadError (==2)

-- Int -- Parse

instance Parse Int where
 parser p=
  do
   TokNum ret<-expectType (TokNum 0)
   return ret
 listParser p=normListParser

-- String -- Parse

instance Parse Char where
 parser=error "This should not be used"
 listParser p=
  do
   ret<-expectNormal
   return ret

-- lists -- Parse

normListParser::(Parse a)=>Parser [a]
normListParser=
 do
  expect (TokSep "[")
  ret<-iterateParserSep (separator (TokSep ",") (TokSep "]"))
                        (parser 0 `mplus` (look (TokSep "]") >> failEnd))
  expect (TokSep "]")
  return ret

instance Parse a=>Parse [a] where
 parser = listParser
 listParser _ = normListParser

-- runParse

runParse::[Token]->Parser a->(State,Maybe a)
runParse inp (Parser pars)=pars $ newState inp

-- eval
eval::(Parse a,Monad m)=>String->m a
eval from=
 case (iErrors,rv) of
  ([],(_,Just ret)) -> return ret
  _                 -> fail $ show from ++ " cannot be parsed."
 where
  tokens=myLex from
  (iTokens,iErrors)=List.partition isCorrectToken tokens
  rv=runParse iTokens (parser 0)

-- run

forErrF::String->[String]->String
forErrF _ []=""
forErrF s x=unlines (s:x)

run::Parse a=>String->IO a
run from=
 do
  putStr $ forErrF "Lexical errors:" lexErrors
  let (state,ret)=runParse iTokens (parser 0)
      rem=stPosition state
      parseErrors=stErrors state
  putStr $ forErrF "Parse errors:" (reverse parseErrors)
  if rem/=[] then putStr $ forErrF "Remaining tokens:" (lines $ show rem)
             else return ()
  case ret of
   Just rt->return rt
   Nothing->fail "Parse failed"
 where
  tokens=myLex from
  (iTokens,iErrors)=List.partition isCorrectToken tokens
  lexErrors=map formatLexError iErrors

-- output routines

formatLexError::Token->String
formatLexError (Token line (TokLexError err))=
  "lexical error (" ++ err ++ ") on line "++ show line

isCorrectToken::Token->Bool
isCorrectToken (Token _ (TokLexError _))=False
isCorrectToken _=True

showPosition::[Token]->String
showPosition []="end of file"
showPosition w@(Token line _:_)="line "++show line++" context: "++show (take 5 w)

-- Lex

myLex::String->[Token]
myLex=myLexN 1

sepChars="[](){};,"
opChars="+-*/=<>@%&|!"

myLexN::Int->String->[Token]
myLexN _ []=[]
myLexN line ('\n':t)=myLexN (line+1) t
myLexN line ('/':'*':t)=let (nline,rest,res)=skipComment line t
                           in res++myLexN nline rest
myLexN line str@(c:t)
 | isSpace c         = myLexN line t
 | isAlpha c         = let (id,rest)=lexIdent line str
                         in id++myLexN line rest
 | isDigit c         = let (num,rest)=lexNum line str
                         in num++myLexN line rest
 | c=='"'            = let (sg,rest)=lexStr line t
                         in sg++myLexN line rest
 | c `elem` sepChars = let (sep,rest)=lexSep line str
                         in sep++myLexN line rest
 | c `elem` opChars  = let (op,rest)=lexOp line str
                         in op++myLexN line rest
 | otherwise         = Token line (TokLexError $ "Unknown char " ++ show c):myLexN line t

skipComment::Int->String->(Int,String,[Token])
skipComment line ('\n':t)=skipComment (line+1) t
skipComment line ""=(line,"",[Token line (TokLexError "Unterminated comment")])
skipComment line ('*':'/':t)=(line,t,[])
skipComment line (_:t)=skipComment line t

identChar::Char->Bool
identChar '_'=True
identChar x=isAlphaNum x

lexIdent::Int->String->([Token],String)
lexIdent line from=([Token line $ TokId id],rest)
  where (id,rest)=span identChar from

lexNum::Int->String->([Token],String)
lexNum line from=([Token line $ TokNum $ read id],rest)
  where (id,rest)=span isDigit from

lexSep::Int->String->([Token],String)
lexSep line (c:t)=([Token line $ TokSep [c]],t)

match::(Eq a)=>[a]->[a]->([a],[a])
match (x:xs) (y:ys) | x == y  =  match xs ys
match xs     ys               =  (xs,ys)       

ops=["->","&&","||","=","!","@","-","%","+","*","/"]
bestOp::String->(String,String)
bestOp from=
 case dropWhile (\(x,_)->x==0) $ zip rating ops of
  []->([],tail from)
  ((len,bop):_)->(bop,drop len from)
 where
  rating=map rate ops
  rate op=case match op from of
           ([],_)->length op
           _->0

lexOp::Int->String->([Token],String)
lexOp line from=
 case bestOp from of
  ([],rest)->([Token line (TokLexError $ "Unknown operator" ++ takeWhile (\c->c `elem` opChars) rest)],rest)
  (op,rest)->([Token line $ TokOp op],rest)

lexStr::Int->String->([Token],String)
lexStr line []=([Token line $ TokStr "",Token line (TokLexError "Unterminated string")],[])
lexStr line rest@('\n':_)=([Token line $ TokStr "",Token line (TokLexError "String contains end of line, probably unterminated")],rest)
lexStr line "\\"=([Token line $ TokStr "\\",Token line (TokLexError "Unterminated string")],[])
lexStr line ('\\':'\\':rest)=addCToTok '\\' $ lexStr line rest
lexStr line ('\\':'\n':rest)=addCToTok '\n' $ lexStr line rest
lexStr line ('\\':'"':rest)=addCToTok '"' $ lexStr line rest
lexStr line ('\\':rest)=addLexErr line ("Unknown escape sequence" ++ show (head rest)) $ addCToTok '\\' $ lexStr line rest
lexStr line ('"':rest)=([Token line $ TokStr ""],rest)
lexStr line (c:rest)=addCToTok c $ lexStr line rest

addCToTok::Char->([Token],String)->([Token],String)
addCToTok c ((Token line (TokStr st):rest),rem)=
            ((Token line (TokStr (c:st)):rest),rem)

addLexErr::Int->String->([Token],String)->([Token],String)
addLexErr line err (to,rem)=(Token line (TokLexError err):to,rem)