{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}
module Parser where
import Text.Parsec
import Data.Char
import Text.Parsec.Language
import Text.Parsec.Token
import Debug.Trace
import Control.Monad.Identity
import System.Directory
import Types
import Utils
import Data.List
import System.IO.Unsafe

println :: (Monad m)
        => String -> m ()
println msg = trace (show msg) $ return ()

functionName
  :: ParsecT String a Identity (HaskellIdentifier,FunctionArgs)
functionName =
  between (char '{')
          (char '}')
          (do spaces
              (try (do name <-
                         manyTill anyChar (char '(')
                       args <- go (1 :: Int) ""
                       return ((toHaskellIdentifier name)
                              ,if (not (null args))
                                  then (FunctionArgs $ Just args)
                                  else FunctionArgs Nothing)) <|>
               (return (UnidentifiedFunction ,(FunctionArgs Nothing)))))
  where
    go :: Int -> String -> ParsecT String a Identity String
    go nesting accum =
      (try $ char '(' >> go (nesting + 1) (accum ++ "(")) <|>
      (try $ lookAhead (char ')') >>
             if (nesting == 0)
               then parserZero
               else if (nesting == 1)
                    then char ')' >> return accum
                    else char ')' >> go (nesting - 1) (accum ++ ")")
      ) <|>
      (do bare <-
            manyTill anyChar ((lookAhead (char ')')) <|> (lookAhead (char '(')))
          go nesting (accum ++ bare)
      )
quotedP
  :: ParsecT String a Identity BracedStringParts
quotedP =
  let charCodeP :: Char -> String -> ParsecT String a Identity BracedStringParts
      charCodeP c code = (char c) >> return (QuotedCharCode code)
  in foldl1 (<|>)
            ((map try
                  [charCodeP 'a' "\\a"
                  ,charCodeP 'b' "\\b"
                  ,charCodeP 'a' "\\a"
                  ,charCodeP 'b' "\\b"
                  ,charCodeP 'f' "\\f"
                  ,charCodeP 'n' "\\n"
                  ,charCodeP 'r' "\\r"
                  ,charCodeP 't' "\\t"
                  ,charCodeP 'v' "\\v"
                  ,((char 'x') >> hexP >>= return . QuotedHex)
                  ,(octalP >>= return . QuotedOctal)]) ++
             [(anyChar >>=
               \c ->
                 return (QuotedChar ("\\" ++ [c])))])

bracedContentsP
  :: ParsecT String () Identity [BracedStringParts]
bracedContentsP = char '{' >> go (0 :: Int) []
  where go nesting accum =
          (try $
           do _ <- string "\\\\"
              quoted <- quotedP
              go nesting (accum ++ [quoted])) <|>
          (try $
           char '{' >>
           go (nesting + 1)
              (accum ++ [BareString "{"])) <|>
          (try $
           lookAhead (char '}') >>
           if (nesting == 0)
              then parserZero
              else char '}' >>
                   go (nesting - 1)
                      (accum ++ [BareString "}"])) <|>
          (try $ (trimAfter $ char '}') >> return accum) <|>
          (do bare <-
                manyTill anyChar
                         ((lookAhead $ string "\\\\") <|> (lookAhead $ string "{") <|>
                          (lookAhead $ string "}"))
              go nesting (accum ++ [BareString bare]))

unbrokenString
  :: ParsecT String a Identity [Char]
unbrokenString =
  manyTill anyChar (char ' ' <|> endOfLine)

toEndOfLine :: ParsecT String a Identity [Char]
toEndOfLine = manyTill anyChar endOfLine

spacesOrNewLines :: ParsecT String a Identity ()
spacesOrNewLines =
  skipMany $ (char ' ') <|> (char '\n') <|> crlf

trimAfter
  :: ParsecT String () Identity a -> ParsecT String () Identity a
trimAfter p =
  do result <- p
     spacesOrNewLines
     return result

chTrim :: Char -> ParsecT String () Identity Char
chTrim c = trimAfter (char c)

-- presentState :: ParsecT String u Identity ()
-- presentState =
--   do s <- getParserState
--      println (stateInput s)

-- presentStateN
--   :: Int -> ParsecT String u Identity ()
-- presentStateN n =
--   do s <- getParserState
--      let out = take n (stateInput s)
--      println out

untilP :: ParsecT String a Identity b
       -> ParsecT String a Identity c
       -> ParsecT String a Identity [b]
untilP keepGoingP stopP = go []
  where go accum =
          (try $ stopP >> return accum) <|>
          (do r <- keepGoingP
              go (accum ++ [r]))

-- printWithIndent endPs msg = println (concat (map (const "-") endPs) ++ msg)

-- nodeP openerP innerP enderP moreOfP endPs = do
--   _ <- openerP
--   let allEnds = [(ignore enderP, ignore (moreOfP endPs))] ++ endPs
--       allEndsP =  tryAllEnds allEnds
--   body <- untilP (innerP allEnds) (lookAhead enderP >> lookAhead allEndsP)
--   _ <- enderP
--   return body

codeP :: String
      -> ([BracedStringParts] -> Attribute)
      -> ParsecT String () Identity Attribute
codeP name cons =
  do _ <- trimAfter $ string name
     body <- bracedContentsP
     return (cons body)

codeOrCallP
  :: String
  -> (UnbrokenOrBraced -> Attribute)
  -> ParsecT String () Identity Attribute
codeOrCallP name cons =
  do _ <- trimAfter $ string name
     body <- literal
     return (cons body)

attrP :: String
      -> (a -> Attribute)
      -> ParsecT String () Identity a
      -> ParsecT String () Identity Attribute
attrP name cons p =
  do _ <- trimAfter $ string name
     body <- p
     return (cons body)

literal
  :: ParsecT String () Identity UnbrokenOrBraced
literal =
  (try $ bracedContentsP >>= return . BracedString) <|>
  (unbrokenString >>= return . UnbrokenString)

pathLiteral
  :: ParsecT String () Identity UnbrokenOrBraced
pathLiteral =
  (try $ do
      bc <- bracedContentsP
      -- take the canonical path relative this the Fluid file since the generated Haskell
      -- file gets put under the `dist` directory and this path will no longer be valid
      return (BracedString [(BareString (unsafePerformIO (canonicalizePath (collapseParts bc))))]))
  <|>
  (unbrokenString >>= return . UnbrokenString)

langDef :: GenTokenParser String a Control.Monad.Identity.Identity
langDef = makeTokenParser haskellDef

integerP :: ParsecT String a Identity Integer
integerP = integer langDef

numberP :: ParsecT String a Identity Integer
numberP = decimal langDef

floatP :: ParsecT String a Identity Double
floatP = float langDef

hexP :: ParsecT String a Identity Integer
hexP = hexadecimal langDef

octalP :: ParsecT String a Identity Integer
octalP = octal langDef

sequenceParsers :: [(ParsecT String u Identity (),ParsecT String u Identity a)]
                -> ParsecT String u Identity ()
sequenceParsers ps =
  try $
  ignore $
  do foldl (>>)
           (return ())
           (map fst ps)
     case ps of
       [] -> parserZero
       _ -> ignore (snd (last ps))

tryAllEnds :: [(ParsecT String () Identity (),ParsecT String () Identity a)]
           -> ParsecT String () Identity ()
tryAllEnds ps =
  foldl1 (<|>) ((map sequenceParsers (inits ps)) ++ [parserZero])

num :: ParsecT String a Identity Int
num =
  integerP >>=
  \n -> return ((fromIntegral n) :: Int)

floatOrInteger
  :: ParsecT String a Identity Double
floatOrInteger =
  (try $ floatP) <|>
  (do i <- integerP
      return ((fromIntegral i) :: Double))

numFourTuple
  :: ParsecT String () Identity (Int,Int,Int,Int)
numFourTuple =
  do _ <- trimAfter (char '{')
     x <- trimAfter numberP
     y <- trimAfter numberP
     w <- trimAfter numberP
     h <- trimAfter numberP
     _ <- trimAfter (char '}')
     return (fromIntegral x,fromIntegral y,fromIntegral w,fromIntegral h)

attrPs :: [ParsecT String () Identity Attribute]
attrPs =
  (map try
       [(codeP "code0" Code0)
       ,(codeP "code1" Code1)
       ,(codeP "code2" Code2)
       ,(codeP "code3" Code3)
       ,(attrP "labelfont" Labelfont num)
       ,(attrP "labelsize" Labelsize num)
       ,(attrP "labeltype" Labeltype unbrokenString)
       ,(attrP "labelcolor" Labelcolor num)
       ,(attrP "label" Label literal)
       ,(codeOrCallP "callback" Callback)
       ,(attrP "xywh" XYWH numFourTuple)
       ,(attrP "color" Color num)
       ,(attrP "maximum" Maximum num)
       ,(attrP "value" Value literal)
       ,(attrP "down_box" DownBox unbrokenString)
       ,(attrP "box" Box unbrokenString)
       ,(string "resizable" >> return Resizable)
       ,(string "visible" >> return Visible)
       ,(attrP "align" Align num)
       ,(attrP "minimum" Minimum num)
       ,(attrP "step" Step floatOrInteger)
       ,(attrP "selection_color" SelectionColor num)
       ,(string "open" >> return Open)
       ,(string "hide" >> return Hide)
       ,(string "in_source" >> return InSource)
       ,(string "in_header" >> return InHeader)
       ,(attrP "return_type" ReturnType literal)
       ,(attrP "type" WidgetType literal)
       ,(string "private" >> return Private)
       ,(attrP "user_data_type" UserDataType literal)
       ,(attrP "user_data" UserData literal)
       ,(attrP "tooltip" Tooltip literal)
       ,(attrP "comment" Comment literal)
       ,(attrP "when" When num)
       ,(string "hotspot" >> return Hotspot)
       ,(string "modal" >> return Modal)
       ,(string "selected" >> return Selected)
       ,(attrP "textfont" TextFont num)
       ,(attrP "textsize" TextSize num)
       ,(attrP "textcolor" TextColor num)
       ,(attrP "slider_size" SliderSize floatOrInteger)
       ,(attrP "class" DerivedFromClass unbrokenString)
       ,(attrP "shortcut" Shortcut unbrokenString)
       ,(attrP "after" AfterCode literal)
       ,(attrP ":" Inherits unbrokenString)
       ,(attrP "#" LineComment toEndOfLine)
       ,(attrP "filename" Filename literal)
       ,(string "local" >> return Local)
       ,(string "global" >> return Global)
       ,(string "deactivate" >> return Deactivate)
       ,(string "public" >> return Public)
       ,(string "divider" >> return Divider)
       ,(attrP "image" Image pathLiteral)
       ,(attrP "deimage" Deimage pathLiteral)]) ++
  [(attrP "size_range" SizeRange numFourTuple)]

innardsP :: ParsecT String () Identity Attribute
innardsP =
  do spacesOrNewLines
     res <- trimAfter (choice (attrPs))
     return res

ignore :: Monad m
       => m a -> m ()
ignore p = p >> return ()

groupTypes
  :: [ParsecT String a Identity String]
groupTypes =
  (map try
     [ (string "Fl_Window")
     , (string "Fl_Group")
     , (string "Fl_Wizard")
     , (string "Fl_Pack")
     , (string "Fl_Table")
     , (string "Fl_Scroll")
     , (string "Fl_Tile")
     ]) ++
  [(string "Fl_Tabs")]

menuTypes
  :: [ParsecT String a Identity String]
menuTypes =
  (map try
     [ (string "Fl_Menu_Bar")
     , (string "Fl_Menu_Button")
     , (string "Fl_Choice")
     , (string "Fl_Input_Choice")
     ]) ++
  [(string "Submenu")]

componentTypes
  :: [ParsecT String a Identity String]
componentTypes =
  (map try
     [ (string "Fl_Slider")
     , (string "Fl_Value_Slider")
     , (string "Fl_Roller")
     , (string "Fl_Box")
     , (string "Fl_Scrollbar")
     , (string "Fl_Adjuster")
     , (string "Fl_Counter")
     , (string "Fl_Roller")
     , (string "Fl_Value_Input")
     , (string "Fl_Value_Output")
     , (string "Fl_Spinner")
     , (string "Fl_Dial")
     , (string "Fl_Button")
     , (string "Fl_Output")
     , (string "MenuItem")
     , (string "Fl_Input")
     , (string "Fl_Clock")
     , (string "Fl_Return_Button")
     , (string "Fl_Light_Button")
     , (string "Fl_Check_Button")
     , (string "Fl_Repeat_Button")
     , (string "Fl_Round_Button")
     , (string "Fl_Help_View")
     , (string "Fl_Browser")
     , (string "Fl_Check_Browser")
     , (string "Fl_File_Browser")
     , (string "Fl_Tree")
     , (string "Fl_Progress")
     , (string "Fl_File_Input")
     , (string "Fl_Text_Display")
     , (string "Fl_Text_Editor")
     ])

testIdentifier :: String
               -> (Char -> Bool)
               -> cons
               -> (String -> cons)
               -> (String -> cons)
               -> cons
testIdentifier idName testFirst unidentifiedCons invalidCons validCons =
  case idName of
    [] -> unidentifiedCons
    (c:_) ->
      if (not (isAlpha c))
        then invalidCons idName
        else if (not (testFirst c))
               then invalidCons idName
               else if (any
                          (\_c -> not
                                    ((_c == '\'') ||
                                     (isAlphaNum _c) ||
                                     (_c == '_')))
                          idName)
                      then invalidCons idName
                      else validCons idName

toHaskellIdentifier :: String -> HaskellIdentifier
toHaskellIdentifier idName =
  testIdentifier idName isLower Unidentified InvalidHaskell ValidHaskell

toModuleIdentifier :: String -> Maybe ModuleIdentifier
toModuleIdentifier modName =
  testIdentifier modName isUpper Nothing (Just . InvalidModule) (Just . ValidModule)

componentsP
  :: ParsecT String () Identity WidgetTree
componentsP =
  do cType <- trimAfter $ choice componentTypes
     name <-
       trimAfter $
       (try $ string "{}" >> return Unidentified) <|>
       (unbrokenString >>= return . toHaskellIdentifier)
     _ <- trimAfter (char '{')
     attrs <-
       manyTill innardsP (trimAfter $ char '}')
     return $ Component cType name attrs

containersP
  :: (Type -> HaskellIdentifier -> [Attribute] -> [WidgetTree] -> WidgetTree) -> [ParsecT String () Identity String] -> ParsecT String () Identity WidgetTree
containersP cons containerTypes =
  do cType <- trimAfter $ choice containerTypes
     name <-
       trimAfter $
       (try $ string "{}" >> return Unidentified) <|>
       (unbrokenString >>= return . toHaskellIdentifier)
     _ <- trimAfter (char '{')
     attrs <-
       manyTill innardsP (trimAfter $ char '}')
     _ <- trimAfter (char '{')
     body <-
       manyTill widgetTreeP (trimAfter $ char '}')
     return $ cons cType name attrs body

menusP :: ParsecT String () Identity WidgetTree
menusP = containersP Menu menuTypes

groupsP :: ParsecT String () Identity WidgetTree
groupsP = containersP Group groupTypes

codeBlockP
  :: ParsecT String () Identity WidgetTree
codeBlockP =
  do _ <- trimAfter $ string "codeblock"
     opener <- literal
     _ <- trimAfter (char '{')
     attrs <-
       manyTill innardsP (trimAfter $ char '}')
     _ <- trimAfter (char '{')
     body <-
       manyTill widgetTreeP (trimAfter $ char '}')
     return $ CodeBlock opener attrs body

argsBodyP :: String
          -> ([Attribute] -> UnbrokenOrBraced -> a)
          -> ParsecT String () Identity a
argsBodyP n cons =
  do _ <- trimAfter $ string n
     body <- literal
     _ <- trimAfter (char '{')
     attrs <-
       manyTill innardsP (trimAfter $ char '}')
     return (cons attrs body)

justArgsP
  :: String
  -> (String -> [Attribute] -> FluidBlock)
  -> ParsecT String () Identity FluidBlock
justArgsP n cons =
  do _ <- trimAfter $ string n
     name <- trimAfter unbrokenString
     _ <- trimAfter (char '{')
     attrs <-
       manyTill innardsP (trimAfter $ char '}')
     return (cons name attrs)

versionP :: ParsecT String () Identity WidgetTree
versionP =
  do _ <- trimAfter $ string "version"
     body <- unbrokenString
     return (Version body)

widgetTreeP
  :: ParsecT String () Identity WidgetTree
widgetTreeP =
  (try $ groupsP) <|> (try $ menusP) <|> (try $ codeBlockP) <|> (try $ componentsP) <|>
  (try $ argsBodyP "code" Code) <|>
  (try $ argsBodyP "comment" StandAloneComment) <|>
  versionP

functionP :: ParsecT String () Identity Function
functionP =
  do _ <- trimAfter $ string "Function"
     (name,args) <- trimAfter (try (string "{}" >> return (UnidentifiedFunction, FunctionArgs Nothing)) <|> functionName)
     _ <- trimAfter (char '{')
     attributes <-
       manyTill innardsP (trimAfter $ char '}')
     _ <- trimAfter (char '{')
     body <-
       manyTill widgetTreeP (trimAfter $ char '}')
     return (Function name args attributes body)

classP :: ParsecT String () Identity Class
classP =
  do _ <-
       trimAfter $ (try $ string "class") <|> (string "widget_class")
     name <- trimAfter unbrokenString
     _ <- trimAfter (char '{')
     otherArgs <-
       manyTill innardsP (trimAfter $ char '}')
     _ <- trimAfter (char '{')
     body <-
       manyTill fluidP (trimAfter $ char '}')
     return (Class (InvalidHaskell name) otherArgs body)

declBlockP
  :: ParsecT String () Identity FluidBlock
declBlockP =
  do _ <- trimAfter $ string "declblock"
     opener <- literal
     _ <- trimAfter (char '{')
     attrs <-
       manyTill innardsP (trimAfter $ char '}')
     _ <- trimAfter (char '{')
     body <-
       manyTill fluidP (trimAfter $ char '}')
     return (DeclBlock attrs opener body)

fluidP :: ParsecT String () Identity FluidBlock
fluidP =
  (try classP >>= return . FluidClass) <|>
  (try functionP >>= return . FluidFunction) <|>
  (try declBlockP) <|>
  (try $ argsBodyP "decl" Decl) <|>
  (justArgsP "data" Data)

runnerP
  :: ParsecT String () Identity [FluidBlock]
runnerP = untilP fluidP (lookAhead eof)

dontCare
  :: String -> ParsecT String a Identity ()
dontCare l =
  do _ <- string l
     _ <- manyTill anyChar endOfLine
     return ()

uselessHeader :: forall u.
                 ParsecT String u Identity ()
uselessHeader =
  dontCare "#" >> dontCare "version" >> dontCare "header_name" >>
  dontCare "code_name"