{-# LANGUAGE TemplateHaskell #-}

module Data.STData.Parse
  ( sexpSTDataTokenValueM , openStructureTokenValueM , closeStructureTokenValueM
  , openTextTokenValueM , closeTextTokenValueM , textTokenValueM
  , isDiscardSTDataToken
  , structureTokens , textTokens
  , lexStructure , lexText
  , parseSData, parseSLink
  , parseTData, parseTLink
  , convertOpenSDataE, convertOpenTDataE
  , convertOpenSDataP, convertOpenTDataP
  , sdata, slink
  , tdata, tlink
  ) where

import Control.Monad
import Data.SExp
import Data.STData.Data
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Text.Parsec
import Text.Parsec.Pos
import Text.Parsec.String
import Text.Printf

data STDataToken =
    SExpSTDataToken SExpToken

  | OpenStructureToken
  | CloseStructureToken
  | OpenTextToken
  | CloseTextToken

  | TextToken String
  deriving (Eq, Ord, Show)

isDiscardSTDataToken :: STDataToken -> Bool
isDiscardSTDataToken (SExpSTDataToken t) = isDiscardSExpToken t
isDiscardSTDataToken _ = False

sexpSTDataTokenValueM :: STDataToken -> Maybe SExpToken
sexpSTDataTokenValueM t = case t of (SExpSTDataToken s) -> Just s ; _ -> Nothing
openStructureTokenValueM :: STDataToken -> Maybe ()
openStructureTokenValueM t = case t of OpenStructureToken -> Just () ; _ -> Nothing
closeStructureTokenValueM :: STDataToken -> Maybe ()
closeStructureTokenValueM t = case t of CloseStructureToken -> Just () ; _ -> Nothing
openTextTokenValueM :: STDataToken -> Maybe ()
openTextTokenValueM t = case t of OpenTextToken -> Just () ; _ -> Nothing
closeTextTokenValueM :: STDataToken -> Maybe ()
closeTextTokenValueM t = case t of CloseTextToken -> Just () ; _ -> Nothing
textTokenValueM :: STDataToken -> Maybe String
textTokenValueM t = case t of (TextToken s) -> Just s ; _ -> Nothing

structureTokens :: [Parser STDataToken]
structureTokens = 
  [ string "t(-(" >> return OpenTextToken
  , string ")-)" >> return CloseStructureToken
  ] ++ liftM (liftM SExpSTDataToken) sexpTokens

textTokens :: [Parser STDataToken]
textTokens =
  [ string "s(-(" >> return OpenStructureToken
  , string ")-)" >> return CloseTextToken
  , let chunk :: Parser String
        chunk = msum
          [ do
              x <- noneOf "s)"
              liftM (x:) $ chunk
          , try possiblyBad
          , return ""
          ]
        possiblyBad :: Parser String
        possiblyBad = msum
          [ do
              x <- char 's'
              liftM (x:) $ chunkPostLetter
          , do
              x <- char ')'
              liftM (x:) $ chunkPostClose
          ]
        chunkPostLetter = msum
          [ do
              x <- noneOf "s)("
              liftM (x:) $ chunk
          , possiblyBad
          , do
              x <- char '('
              liftM (x:) $ chunkPostLetterOpen
          ]
        chunkPostLetterOpen = msum
          [ do
              x <- noneOf "s)-"
              liftM (x:) $ chunk
          , possiblyBad
          , do
              x <- char '-'
              liftM (x:) $ chunkPostLetterOpenDash
          ]
        chunkPostLetterOpenDash = msum
          [ do
              x <- noneOf "s)("
              liftM (x:) $ chunk
          , possiblyBad
          ]
        chunkPostClose = msum
          [ do
              x <- noneOf "s)-"
              liftM (x:) $ chunk
          , possiblyBad
          , do
              x <- char '-'
              liftM (x:) $ chunkPostCloseDash
          ]
        chunkPostCloseDash = msum
          [ do
              x <- noneOf "s)"
              liftM (x:) $ chunk
          , do
              x <- char 's'
              liftM (x:) $ chunkPostLetter
          ]
    in liftM TextToken chunk            
  ]

lexStructure :: String -> Either String [(SourcePos, STDataToken)]
lexStructure i = do
  (result, o, i') <- lexStructure' (initialPos "") i
  case i' of
    [] -> return $ filter (not . isDiscardSTDataToken . snd) result
    _ -> fail $ printf "did not consume all input: %s" (show o)

lexStructure' :: SourcePos -> String -> Either String ([(SourcePos, STDataToken)], SourcePos, String)
lexStructure' o [] = return ([], o, [])
lexStructure' o i = do
  (r@(_, t), o', i') <- lexOne o structureTokens i
  case t of
    OpenTextToken -> do
      (tsFlat, oFlat, iFlat) <- lexText' o' i'
      (tsTail, oTail, iTail) <- lexStructure' oFlat iFlat
      return (r : (tsFlat ++ tsTail), oTail, iTail)
    CloseStructureToken -> do
      return ([r], o', i')
    _ -> do
      (tsTail, oTail, iTail) <- lexStructure' o' i'
      return (r : tsTail, oTail, iTail)

lexText :: String -> Either String [(SourcePos, STDataToken)]
lexText i = do
  (result, o, i') <- lexText' (initialPos "") i
  case i' of
    [] -> return $ filter (not . isDiscardSTDataToken . snd) result
    _ -> fail $ printf "did not consume all input: %s" (show o)

lexText' :: SourcePos -> String -> Either String ([(SourcePos, STDataToken)], SourcePos, String)
lexText' o [] = return ([], o, [])
lexText' o i = do
  (r@(_, t), o', i') <- lexOne o textTokens i
  case t of
    OpenStructureToken -> do
      (tsLink, oLink, iLink) <- lexStructure' o' i'
      (tsTail, oTail, iTail) <- lexText' oLink iLink
      return (r : (tsLink ++ tsTail), oTail, iTail)
    CloseTextToken -> do
      return ([r], o', i')
    _ -> do
      (tsTail, oTail, iTail) <- lexText' o' i'
      return (r : tsTail, oTail, iTail)

-- Parsing

type STDataParser a = GenParser (SourcePos, STDataToken) () a

stDataTokenParser :: (STDataToken -> Maybe a) -> STDataParser a
stDataTokenParser f = token show fst (f . snd)

stringTok       :: STDataParser String  ; stringTok       = stDataTokenParser $ sexpSTDataTokenValueM >=> stringTokenValueM
booleanTok      :: STDataParser Bool    ; booleanTok      = stDataTokenParser $ sexpSTDataTokenValueM >=> booleanTokenValueM
integerTok      :: STDataParser Integer ; integerTok      = stDataTokenParser $ sexpSTDataTokenValueM >=> integerTokenValueM
floatingTok     :: STDataParser Double  ; floatingTok     = stDataTokenParser $ sexpSTDataTokenValueM >=> floatingTokenValueM
symbolTok       :: STDataParser String  ; symbolTok       = stDataTokenParser $ sexpSTDataTokenValueM >=> symbolTokenValueM
lParenTok       :: STDataParser ()      ; lParenTok       = stDataTokenParser $ sexpSTDataTokenValueM >=> lParenTokenValueM
rParenTok       :: STDataParser ()      ; rParenTok       = stDataTokenParser $ sexpSTDataTokenValueM >=> rParenTokenValueM
antiConsTok     :: STDataParser ()      ; antiConsTok     = stDataTokenParser $ sexpSTDataTokenValueM >=> antiConsTokenValueM
antiValueTok    :: STDataParser String  ; antiValueTok    = stDataTokenParser $ sexpSTDataTokenValueM >=> antiValueTokenValueM
antiAtomTok     :: STDataParser String  ; antiAtomTok     = stDataTokenParser $ sexpSTDataTokenValueM >=> antiAtomTokenValueM
antiStringTok   :: STDataParser String  ; antiStringTok   = stDataTokenParser $ sexpSTDataTokenValueM >=> antiStringTokenValueM
antiBooleanTok  :: STDataParser String  ; antiBooleanTok  = stDataTokenParser $ sexpSTDataTokenValueM >=> antiBooleanTokenValueM
antiIntegerTok  :: STDataParser String  ; antiIntegerTok  = stDataTokenParser $ sexpSTDataTokenValueM >=> antiIntegerTokenValueM
antiFloatingTok :: STDataParser String  ; antiFloatingTok = stDataTokenParser $ sexpSTDataTokenValueM >=> antiFloatingTokenValueM
antiSymbolTok   :: STDataParser String  ; antiSymbolTok   = stDataTokenParser $ sexpSTDataTokenValueM >=> antiSymbolTokenValueM

openStructureTok  :: STDataParser ()     ; openStructureTok  = stDataTokenParser openStructureTokenValueM
closeStructureTok :: STDataParser ()     ; closeStructureTok = stDataTokenParser closeStructureTokenValueM
openTextTok       :: STDataParser ()     ; openTextTok       = stDataTokenParser openTextTokenValueM
closeTextTok      :: STDataParser ()     ; closeTextTok      = stDataTokenParser closeTextTokenValueM
textTok           :: STDataParser String ; textTok           = stDataTokenParser textTokenValueM

atomP :: STDataParser Atom
atomP = msum
  [ liftM StringAtom stringTok
  , liftM BooleanAtom booleanTok
  , liftM IntegerAtom integerTok
  , liftM FloatingAtom floatingTok
  , liftM SymbolAtom symbolTok
  ]

antiAtomP :: STDataParser AntiAtom
antiAtomP = msum
  [ liftM ValueAntiAtom antiValueTok
  , liftM AtomAntiAtom antiAtomTok
  , liftM StringAntiAtom antiStringTok
  , liftM BooleanAntiAtom antiBooleanTok
  , liftM IntegerAntiAtom antiIntegerTok
  , liftM FloatingAntiAtom antiFloatingTok
  , liftM SymbolAntiAtom antiSymbolTok
  ]

sdataP :: STDataParser SData
sdataP = msum
  [ liftM (SData . AtomSData) atomP
  , liftM (SData . SLinkSData) $ between lParenTok rParenTok slinkP
  , liftM (SData . TLinkSData) $ between openTextTok closeTextTok tlinkP
  ]

slinkP :: STDataParser SLink
slinkP = msum
  [ do
      s <- sdataP
      ss <- slinkP
      return . SLink $ ConsLink s ss
  , do
      return $ SLink NullLink
  ]

tdataP :: STDataParser TData
tdataP = msum
  [ liftM (TData . AtomTData) textTok
  , liftM (TData . SLinkTData) $ between openStructureTok closeStructureTok slinkP
  ]

tlinkP :: STDataParser TLink
tlinkP = msum
  [ do
      t <- tdataP
      ts <- tlinkP
      return . TLink $ ConsLink t ts
  , return $ TLink NullLink
  ]

dualSDataP :: STDataParser DualSData
dualSDataP = msum
  [ liftM (PositiveDualSData . AtomSData) atomP
  , liftM AntiAtomDualSData antiAtomP
  , liftM (PositiveDualSData . SLinkSData) $ between lParenTok rParenTok dualSLinkP
  , liftM (PositiveDualSData . TLinkSData) $ between openTextTok closeTextTok dualTLinkP
  ]

dualSLinkP :: STDataParser DualSLink
dualSLinkP = msum
  [ do 
      s <- dualSDataP 
      ss <- dualSLinkP 
      return . PositiveDualSLink $ ConsLink s ss
  , do 
      antiConsTok 
      anti <- antiValueTok 
      return $ AntiConsDualSLink anti
  , return $ PositiveDualSLink NullLink
  ]

dualTDataP :: STDataParser DualTData
dualTDataP = msum
  [ liftM (DualTData . AtomTData) textTok
  , liftM (DualTData . SLinkTData) $ between openStructureTok closeStructureTok dualSLinkP
  ]

dualTLinkP :: STDataParser DualTLink
dualTLinkP = msum
  [ do
      t <- dualTDataP
      ts <- dualTLinkP
      return . DualTLink $ ConsLink t ts
  , return $ DualTLink NullLink
  ]

parseSData :: String -> Either String SData
parseSData = tokParse lexStructure sdataP

parseSLink :: String -> Either String SLink
parseSLink = tokParse lexStructure slinkP

parseTData :: String -> Either String TData
parseTData = tokParse lexText tdataP

parseTLink :: String -> Either String TLink
parseTLink = tokParse lexText tlinkP

-- Quasi Quoting

convertOpenSDataE :: (sl -> Q Exp) -> (tl -> Q Exp) -> OpenSData sl tl -> Q Exp
convertOpenSDataE _ _ (AtomSData a) = conE 'AtomSData `appE` convertAtomE a
convertOpenSDataE csl _ (SLinkSData sl) = conE 'SLinkSData `appE` csl sl
convertOpenSDataE _ ctl (TLinkSData tl) = conE 'TLinkSData `appE` ctl tl

convertOpenTDataE :: (sl -> Q Exp) -> OpenTData sl -> Q Exp
convertOpenTDataE _ (AtomTData s) = conE 'AtomTData `appE` litE (stringL s)
convertOpenTDataE csl (SLinkTData sl) = conE 'SLinkTData `appE` csl sl

convertDualSDataToSDataE :: DualSData -> Q Exp
convertDualSDataToSDataE (PositiveDualSData p) = 
  conE 'SData `appE` convertOpenSDataE convertDualSDataToSDataLinkE convertDualTDataToTDataLinkE p
convertDualSDataToSDataE (AntiAtomDualSData aa) = 
  conE 'SData `appE` conE 'AtomSData `appE` convertAntiAtomToAtomE aa

convertDualSDataToSDataLinkE :: DualSLink -> Q Exp
convertDualSDataToSDataLinkE (PositiveDualSLink p) =
  conE 'SLink `appE` convertOpenLinkE convertDualSDataToSDataE convertDualSDataToSDataLinkE p
convertDualSDataToSDataLinkE (AntiConsDualSLink name) =
  conE 'SLink `appE` varE (mkName name)

convertDualTDataToTDataE :: DualTData -> Q Exp
convertDualTDataToTDataE (DualTData p) = 
  conE 'TData `appE` convertOpenTDataE convertDualSDataToSDataLinkE p
convertDualTDataToTDataLinkE :: DualTLink -> Q Exp
convertDualTDataToTDataLinkE (DualTLink p) =
  conE 'TLink `appE` convertOpenLinkE convertDualTDataToTDataE convertDualTDataToTDataLinkE p

convertOpenSDataP :: (sl -> Q Pat) -> (tl -> Q Pat) -> OpenSData sl tl -> Q Pat
convertOpenSDataP _ _ (AtomSData a) = conP 'AtomSData [convertAtomP a]
convertOpenSDataP csl _ (SLinkSData sl) = conP 'SLinkSData [csl sl]
convertOpenSDataP _ ctl (TLinkSData tl) = conP 'TLinkSData [ctl tl]

convertOpenTDataP :: (sl -> Q Pat) -> OpenTData sl -> Q Pat
convertOpenTDataP _ (AtomTData s) = conP 'AtomTData [litP (stringL s)]
convertOpenTDataP csl (SLinkTData sl) = conP 'SLinkTData [csl sl]

convertDualSDataToSDataP :: DualSData -> Q Pat
convertDualSDataToSDataP (PositiveDualSData p) = 
  conP 'SData [convertOpenSDataP convertDualSDataToSDataLinkP convertDualTDataToTDataLinkP p]
convertDualSDataToSDataP (AntiAtomDualSData aa) = 
  conP 'SData [conP 'AtomSData [convertAntiAtomToAtomP aa]]

convertDualSDataToSDataLinkP :: DualSLink -> Q Pat
convertDualSDataToSDataLinkP (PositiveDualSLink p) =
  conP 'SLink [convertOpenLinkP convertDualSDataToSDataP convertDualSDataToSDataLinkP p]
convertDualSDataToSDataLinkP (AntiConsDualSLink name) =
  conP 'SLink [varP (mkName name)]

convertDualTDataToTDataP :: DualTData -> Q Pat
convertDualTDataToTDataP (DualTData p) = 
  conP 'TData [convertOpenTDataP convertDualSDataToSDataLinkP p]
convertDualTDataToTDataLinkP :: DualTLink -> Q Pat
convertDualTDataToTDataLinkP (DualTLink p) =
  conP 'TLink [convertOpenLinkP convertDualTDataToTDataP convertDualTDataToTDataLinkP p]

sdata :: QuasiQuoter
sdata = QuasiQuoter 
  { quoteExp = convertDualSDataToSDataE <=< qtokParse lexStructure dualSDataP
  , quotePat = convertDualSDataToSDataP <=< qtokParse lexStructure dualSDataP
  , quoteType = undefined
  , quoteDec = undefined
  }

slink :: QuasiQuoter
slink = QuasiQuoter 
  { quoteExp = convertDualSDataToSDataLinkE <=< qtokParse lexStructure dualSLinkP
  , quotePat = convertDualSDataToSDataLinkP <=< qtokParse lexStructure dualSLinkP
  , quoteType = undefined
  , quoteDec = undefined
  }

tdata :: QuasiQuoter
tdata = QuasiQuoter 
  { quoteExp = convertDualTDataToTDataE <=< qtokParse lexText dualTDataP
  , quotePat = convertDualTDataToTDataP <=< qtokParse lexText dualTDataP
  , quoteType = undefined
  , quoteDec = undefined
  }

tlink :: QuasiQuoter
tlink = QuasiQuoter 
  { quoteExp = convertDualTDataToTDataLinkE <=< qtokParse lexText dualTLinkP
  , quotePat = convertDualTDataToTDataLinkP <=< qtokParse lexText dualTLinkP
  , quoteType = undefined
  , quoteDec = undefined
  }