get-comments.hs

import System.IO
import Control.Monad

whileFM :: (Monad m) => m Bool -> (s -> m s) -> s -> m s
whileFM b f s = b >>= while' where
  while' False = return s
  while' True = (f s) >>= (\newS -> whileFM b f newS)

andM :: (Monad m) => m Bool -> m Bool -> m Bool
andM a b = a >>= (\x ->
  if x then b
  else return False)

notM :: (Monad m) => m Bool -> m Bool
notM a = a >>= (\x -> return $ not x)

whileNotEOF = whileFM (hIsOpen stdin `andM` (notM isEOF))

main :: IO ()
main = whileNotEOF parse' initState >>= finishParse' where
  parse' s = (parse s) `liftM` getChar >>= (\newS ->
    printIfParsed newS >> return newS)

  finishParse' s = case (parse s '\n') of
                     (Parsed x) -> putStrLn x >> return ()
                     _          -> return ()

  printIfParsed (Parsed x) = putStrLn x
  printIfParsed _ = return ()

data CommentState =
  Slash |
  SingleLine {
    singleLineCommentChars :: [Char]
  } |
  MultiLine {
    multiLineCommentChars :: [Char],
    lastStar :: Bool,
    leadingSpaces :: Bool
  }
    deriving Show

data StringState = StringParseState { parsingStringLastBackSlash :: Bool } deriving Show

data ParsingState =
  ParsingComment CommentState | ParsingString StringState
    deriving Show

data ParseState =
  Skip | Parsing ParsingState | Parsed String
    deriving Show

initState = Skip

parse :: ParseState -> Char -> ParseState
parse (Parsing (ParsingComment cs)) c = parseComment cs c
  where
    parseComment :: CommentState -> Char -> ParseState
    parseComment Slash '/' = Parsing $ ParsingComment $ SingleLine "//"
    parseComment Slash '*' = Parsing $ ParsingComment $ MultiLine "*/" False False
    parseComment Slash  _  = Skip
    parseComment (SingleLine chars) '\r' = Parsing $ ParsingComment $ SingleLine chars
    parseComment (SingleLine chars) '\n' = Parsed $ reverse chars
    parseComment (SingleLine chars)   c  = Parsing $ ParsingComment $ SingleLine $ c:chars
    parseComment (MultiLine chars    _ _) c@'*'  = Parsing $ ParsingComment $ MultiLine (c:chars) True False
    parseComment (MultiLine chars    _ _) c@'\n' = Parsing $ ParsingComment $ MultiLine (c:chars) False True
    parseComment (MultiLine chars True _)   '/'  = Parsed $ reverse $ '/':chars
    parseComment (MultiLine chars _ True)   ' '  = Parsing $ ParsingComment $ MultiLine chars False True
    parseComment (MultiLine chars _ _)    c      = Parsing $ ParsingComment $ MultiLine (c:chars) False False
parse (Parsing (ParsingString  ss)) c = parseString ss c
  where
    parseString (StringParseState True)   _   = Parsing $ ParsingString $ StringParseState False
    parseString (StringParseState False) '"'  = Skip
    parseString (StringParseState False) '\\' = Parsing $ ParsingString $ StringParseState True
    parseString (StringParseState False)  _   = Parsing $ ParsingString $ StringParseState False
parse _ '/' = Parsing $ ParsingComment Slash
parse _ '"' = Parsing $ ParsingString $ StringParseState False
parse _  _  = Skip

$ cat titlesGraphTreeDirective.js | runhaskell first.hs 
// config here
// value from 0 to 0.5
// svg static containers/etc
// sorting by fixedLayers hints
// using verticalPairs hints, adding nulls between elements,
// and then fill them, if possible
// i -- layerA, j -- layerB index
//console.log(layerA[k] + ' <-> ' + layerB[toI]);
// jshint loopfunc:true
//return Math.max(match[0] + x.layerAOffset, match[1] + x.layerBOffset);
// collect blocks from layers
// TODO: underblock, multisegment arrows
// form layers
// jshint loopfunc:true
// not acyclic graph
// list of lists
// split trees into connected components
//cornersRadius = options.cornersRadius,
/*var d = [[data[0][0].x, data[0][0].y], [data[0][1].x, data[0][1].y]].map(function(x) {
          return 'L' + x.join(' ');
        }).join(' ');*/