pathtype-0.7: tool/CreateTest.hs

module Main where

import qualified Control.Functor.HT as FuncHT
import Control.Applicative ((<$>), (<$))
import Data.List (stripPrefix, isInfixOf)
import Data.Maybe (mapMaybe)
import Data.Tuple.HT (mapFst)
import Data.Char (isSpace)

import Text.Printf (printf)


srcfiles :: [String]
template, testModule, tok, testPrefix :: String

srcfiles   =
   map ("src/System/Path/" ++) $
   ["Internal.hs", "Directory.hs", "IO.hs"]
template   = "test/TestTemplate.hs"
testModule = "test/TestResult.hs"
tok        = "<TESTS_GO_HERE>"
testPrefix = "-- >> "

main :: IO ()
main = do
  let readFileNumbered path =
        zip ((,) path <$> [(0::Int)..]) . lines <$> readFile path
  testLines <-
     mapMaybe (FuncHT.mapSnd $ stripPrefix testPrefix) .
     map (\(n,row) -> mapFst ((,) n) $ span isSpace row) .
     concat
        <$> mapM readFileNumbered srcfiles
  (templateHead,_:templateTail) <-
     break (tok `isInfixOf`) . lines <$> readFile template
  {-
  Choose the same indentation depth as in the source file,
  such that GHC reports precise source file locations.
  -}
  let outLines =
        (\(((src,n),ind),t) ->
           printf "  {-# LINE %d \"%s\" #-}\n  (%s,\n%s%s%s) :"
              n src (show t) ind (' ' <$ testPrefix) t)
         <$> testLines

  writeFile testModule $ unlines $
     ("{- Do not edit! Created from " ++ template ++ " -}") :
     templateHead ++ outLines ++ templateTail