content: {-# LANGUAGE MultiParamTypeClasses, OverloadedStrings #-}
  
  {- |
     Module      : TestParsing
     Description : Check if the graphviz parser can parse "real world" Dot code.
     Copyright   : (c) Ivan Lazar Miljenovic
     License     : 3-Clause BSD-style
     Maintainer  : Ivan.Miljenovic@gmail.com
  
     This module defines a program that determines if the provided files
     containing Dot code can be properly parsed using graphviz's parsers
     (with the assumption that the provided code is valid).
  
  -}
  module Main (main) where
  
  import           Data.GraphViz
  import           Data.GraphViz.Commands.IO       (toUTF8)
  import           Data.GraphViz.Exception
  import           Data.GraphViz.Parsing           (runParser)
  import           Data.GraphViz.PreProcessing     (preProcess)
  import qualified Data.GraphViz.Types.Generalised as G
  
  import           Control.Exception    (SomeException, evaluate, try)
  import           Control.Monad        (filterM, liftM)
  import qualified Data.ByteString.Lazy as B
  import           Data.Either          (either)
  import           Data.Monoid          (mappend)
  import           Data.Text.Lazy       (Text)
  import qualified Data.Text.Lazy       as T
  import           System.Directory
  import           System.Environment   (getArgs)
  import           System.FilePath
  
  -- -----------------------------------------------------------------------------
  
  main :: IO ()
  main = tryParsing =<< getArgs
    where
      tryParsing []   = putStrLn "Test that the graphviz library can parse\
                                 \ \"real life\" Dot code by passing a list\n\
                                 \of files in which contain Dot graphs.\n\
                                 \\n\
                                 \One way of using this file:\n\t\
                                 \$ locate -r \".*\\.\\(gv\\|dot\\)$\" -0\
                                 \ | xargs -0 TestParsing.hs"
      tryParsing [fp] = do isDir <- doesDirectoryExist fp
                           if isDir
                              then mapM_ tryParseFile =<< getDContents fp
                              else tryParseFile fp
      tryParsing fs = mapM_ tryParseFile fs
  
  getDContents :: FilePath -> IO [FilePath]
  getDContents fp = (filterM doesFileExist . map (fp </>)) =<< getDirectoryContents fp
  
  -- -----------------------------------------------------------------------------
  
  withParse :: (Show a, PPDotRepr dg n) => (a -> IO Text) -> (dg n -> IO ())
               -> (ErrMsg -> String) -> a -> IO ()
  withParse toStr withDG cmbErr a = do dc <- liftM getMsg . try $ toStr a
                                       case dc of
                                         Right dc' -> do edg <- tryParse dc'
                                                         case edg of
                                                           (Right dg) -> withDG dg
                                                           (Left err) -> do putStr (show a)
                                                                            putStrLn " - Parsing problem!"
                                                                            putStrLn $ cmbErr err
                                                                            putStrLn  ""
                                         Left err  -> do putStr (show a)
                                                         putStrLn " - IO problem!"
                                                         putStrLn err
                                                         putStrLn ""
    where
      getMsg :: Either SomeException Text -> Either ErrMsg Text
      getMsg = either (Left . show) Right
  
  type GDG = G.DotGraph Text
  type ErrMsg = String
  
  tryParseFile    :: FilePath -> IO ()
  tryParseFile fp = withParse readUTF8File
                              ((`seq` return ()) . T.length . printDotGraph . asGDG)
                              ("Cannot parse as a G.DotGraph: "++)
                              fp
    where
      asGDG :: GDG -> GDG
      asGDG = id
  
  tryParse    :: (PPDotRepr dg n) => Text -> IO (Either ErrMsg (dg n))
  tryParse dc = handle getErr
                $ let (dg, rst) = runParser parse $ preProcess dc
                  in T.length rst `seq` return (eitherLR (augmentErr rst) id dg)
    where
      getErr :: SomeException -> IO (Either ErrMsg a)
      getErr = return . Left . show
  
      augmentErr rst err = err ++ "\n\tRemaining input: " ++ show res
        where
          sampleLen = 35
  
          res | T.length rst <= sampleLen = rst
              | otherwise                 = T.take sampleLen rst `mappend` " ..."
  
      eitherLR f g = either (Left . f) (Right . g)
  
  -- Force any encoding errors into the IO section rather than when parsing.
  readUTF8File    :: FilePath -> IO Text
  readUTF8File fp = do cnts <- liftM toUTF8 $ B.readFile fp
                       _ <- evaluate $ T.length cnts
                       return cnts
  