content: module ASTParser where
  {-----------------------
  "Words. Nothing but sweet, sweet words that turn into bitter orange wax in my ears."
  -Fry, Futurama
  
  This module parses yaml files created by Larry Wall's MADSKILLS parser.
  It is designed to be used with ASTTranslate, but feel free to use it elsewhere
  if it's useful.
  
  Parsec is used for parsing, which should come standard with GHC.
  
  See ASTTranslate.hs for more.
  
  Originally created by Sage LaTorra for Summer of Code 2006.
  ------------------------}
  import Text.ParserCombinators.Parsec
  import IO hiding (try)
  import ASTUtil
  import ASTDefinition
  
  {-------------
  nodeNamer is parsec parser that parses nodes, recursivley parsing child nodes. It has two distinct cases, 
  one for nodes with kids, one for all other nodes.
  ---------------}
  nodeNamer :: Int -> Parser P5AST
  nodeNamer indent = do
      choice[(count indent space),(count 0 space)] --The count 0 space option accounts for nodes after the chomp modifier on a uni block, since the uni block will consume everything up to the '-'
      choice [hereDoc indent, withKids indent , noKids indent , blank indent]
  
  
  {-A blank looks like 
  - ''
  and since it needs to return _something_, it just returns junk with no real text.
  The int parameter is the whitespace it expects.
  -}
  blank :: Int -> Parser P5AST
  blank indent = do
      try (string "- ''")
      newline
      return (LiteralNode "junk" "1" "")
  
  {-
  A node with kids has a nodetype and a list of nodes (which may be empty).
  The int parameter is the whitespace it expects.
  -}
  withKids :: Int -> Parser P5AST
  withKids indent = do
      try (string "- !perl/P5AST::") <?> "P5AST decleration";
      name <- manyTill anyChar space
      newline
      spaces
      string "Kids: " <?> "Kids"
      modifier <- manyTill anyChar newline
      kids <- case modifier of
          "[]"    -> (newline <?> "newline") >> return []
          _       -> many . try $ nodeNamer (indent+4)
      return $AbstractNode name kids
  
  
  {-
  A node without kids has a type, and enc and uni fields.
  The int parameter is the whitespace it expects.
  -}
  noKids :: Int -> Parser P5AST
  noKids indent = do
      try (string "- !perl/p5::") <?> "p5 decleration"
      name <- manyTill anyChar space
      manyTill anyToken newline
      spaces
      string "enc: "
      enc <- manyTill anyChar newline <?> "enc string"
      spaces
      string "uni: "
      --Uniblock deals with the various types of yaml blocks
      uni <- uniBlock (indent + 4) <?> "uni string/block"
      return $ LiteralNode name enc uni
  
  {-
  A heredoc is basically a node with kids, but it also has a start and an end node.
  The int parameter is the whitespace it expects.
  -}
  hereDoc :: Int -> Parser P5AST
  hereDoc indent = do
      try (string "- !perl/P5AST::heredoc ") <?> "Heredoc decleration";
      newline
      spaces
      string "doc: !perl/P5AST::"
      doc <- manyTill anyChar space
      newline
      spaces
      string "Kids: "
      newline
      kids <- many (try (nodeNamer (indent+6)))
      spaces
      string "end: !perl/p5::closequote "
      newline
      spaces
      string "enc: "
      endenc <- manyTill anyChar newline
      spaces
      string "uni: "
      enduni <- uniBlock (indent + 6) 
      spaces
      string "start: !perl/p5::openquote "
      newline
      spaces
      string "enc: "
      startenc <- manyTill anyChar newline
      spaces
      string "uni: "
      startuni <- uniBlock (indent + 6)
      return (Heredoc doc (LiteralNode "openquote" startenc startuni) (LiteralNode "closequote" endenc enduni) kids)
      
      
      
  
      
  {-
  Uniblock handles the various types of yaml blocks used, those being a literal string (i.e. "..." or even just ...)
  A block "|\n ..." or a block with a chomp modifier "|+\n ..."
  -}
  uniBlock :: Int -> Parser String
  uniBlock indent = choice
      [do try $ string "|\n"
          uni <- manyTill (manyTill anyToken newline) (try(newline)) <?> "uni block";
          return (unlines (map (drop indent) uni))
      ,do try $ string "|+"
          newline;
          uni <- manyTill (manyTill anyToken newline) (try(choice [try(do{count (indent-4) space; notFollowedBy (char ' ')}), try(do{count (indent-8) space; notFollowedBy (char ' ')}), try(eof)])) <?> "uni block with chomp modifier"; -- A block with the chomp modifier ends when there's a line with too few spaces (which means another node (or the end part of a heredoc) is starting.
          return (unlines (map (drop indent) uni))
      ,do try $ string "|-"
          newline;
          uni <- manyTill (manyTill anyToken newline) (try(choice [try(do{count (indent-4) space; notFollowedBy (char ' ')}), try(do{count (indent-8) space; notFollowedBy (char ' ')})])) <?> "uni block with chomp modifier"; -- A block with the chomp modifier ends when there's a line with too few spaces (which means another node (or the end part of a heredoc) is starting.
          return (unlines (map (drop indent) uni))
      ,do try $ string "\""
          uni <- manyTill anyToken (try(string("\"\n")))
          --return uni
          return $ if ((length (lines uni))==1) then (makeLiterals uni) else (makeLiterals (joinString ((head (lines (getRidOfExtraSlashes uni))):(map (drop indent) (tail (lines (getRidOfExtraSlashes uni)))))))
      ,do uni <- manyTill anyToken newline <?> "uni string"
          --If the field is in quotes, strip the quotes by stripping the first character, 
          --reversing the string, stripping the first character, then reversing again
          return $ if (head uni `elem` "\"'")
              then (makeLiterals (reverse (tail (reverse (tail uni)))))
              else uni
      ]
  
  
  --A wrapper for nodeNamer, to handle the junk at the beginning of the file.
  
  parseInput :: Parser [P5AST]
  parseInput = choice [do{try(manyTill anyToken (string "Kids: \n")); names <- many (nodeNamer 2); eof; return names}, return []]
  
  
  {-This function deals with extra slashes that show up in text -}
  
  getRidOfExtraSlashes :: String -> String
  getRidOfExtraSlashes []   = []
  getRidOfExtraSlashes inSt = if (and [((head inSt)=='\\'), ((head (tail inSt))=='\n')]) then ('\n':(getRidOfExtraSlashes (drop 2 inSt))) else ((head inSt):(getRidOfExtraSlashes (tail inSt)))
  
  
  {-Function to handle escaped characters in a string scanned from input.
  For example, if the string "blah\n" is scanned, it ends up being represented as
  "blah\\n". This function parses that newline into a literal newline.-}
  
  makeLiterals :: String -> String
  makeLiterals []   = []
  makeLiterals inSt = if ((head inSt)=='\\') then if (head (tail inSt) == '"') then ('\"':(makeLiterals(drop 2 inSt))) else
                                                     if (head (tail inSt) == 'n') then ('\n':(makeLiterals(drop 2 inSt))) else
                                                       if (head (tail inSt) == 't') then ('\t':(makeLiterals(drop 2 inSt))) else
                                                         if(head (tail inSt) == '\n') then ('\n':(makeLiterals(drop 2 inSt))) else
                                                           if (head (tail inSt) == '\\') then ('\\':(makeLiterals(drop 2 inSt))) else 
                                                             ((makeLiterals(tail inSt)))
                        else ((head inSt):(makeLiterals (tail inSt)))
  
  
  {- No longer a big big messy function to print all the different node types, 
  now a slim function to print everything to a file.
  Only two cases: LiteralNode and AbstractNode.
  For a literal node, print the uni field.
  For an abstract node, recursivley call printTree on the kids (if there are any).
  All output is to a file
  -}
  
  printTree :: Handle -> P5AST -> String -> IO ()
  printTree outFile (LiteralNode atype _ uni) options    = if (and [(atype=="UnknownLit"),('u' `elem` options)]) then do{ hPutStr outFile "UnknownLit"; putStrLn "UNKNOWN: UnknownLit"; hPutStr outFile uni} else (hPutStr outFile uni)
  printTree outFile (AbstractNode atype []) options      = if (and [(atype=="UnknownAbs"),('u' `elem` options)]) then do{ hPutStr outFile "UnknownAbs"; putStrLn "UNKNOWN: UnknownAbs"; hPutStr outFile ""} else (hPutStr outFile "")
  printTree outFile (AbstractNode atype kids) options    = if (and [(atype=="UnknownAbs"),('u' `elem` options)]) then do{ hPutStr outFile "UnknownAbs"; putStrLn "UNKNOWN: UnknownAbs"; printTree outFile (head kids) options; printTree outFile (AbstractNode "P5AST" (tail kids)) options} else do{ printTree outFile (head kids) options; printTree outFile (AbstractNode "P5AST" (tail kids)) options}
  printTree outFile (Heredoc doc start end kids) options = do{ printTree outFile start options;
      hPutStr outFile "\n";
      printTree outFile (AbstractNode "P5AST" kids) options;
      printTree outFile end options}
  
  