module Format where

import qualified ModuleName
import Parse (Module(..), Line, Column)
import Test.DocTest.Parse (DocTest(Property, Example))
import Test.DocTest.Location (Located(Located))

import qualified Data.Monoid.HT as Mn
import Data.Semigroup ((<>))
import Data.Foldable (foldMap)
import Data.Char (isSpace)

import qualified System.Path.IO as PathIO
import qualified System.Path.PartClass as PathClass
import qualified System.Path as Path
import System.Path.Directory (createDirectoryIfMissing)
import System.Path ((</>))

import Text.Printf (printf)



indentRemainder :: Int -> String -> String
indentRemainder n str =
   let (prefix, suffix) = break isSpace str
   in prefix ++ Mn.when (not $ null suffix) (replicate n ' ' ++ suffix)


type Pos = (Line, Column)

type Flags = (Bool, Bool)

writeTestSuite ::
   (PathClass.AbsRel ar) =>
   Path.Dir ar ->
   ModuleName.T -> Flags -> [Module [Located Pos DocTest]] -> IO ()
writeTestSuite outDir testPrefix flags ms = do
   let testDir = outDir </> ModuleName.dirPath testPrefix
   mapM_ (writeTestModule testDir testPrefix flags) ms

writeTestMain ::
   (PathClass.AbsRel ar) =>
   Path.File ar -> ModuleName.T ->
   ModuleName.T -> [Module [Located Pos DocTest]] -> IO ()
writeTestMain path mainName testPrefix ms = do
   let indent = map ("    " ++)
   let prefixed = ModuleName.string . (testPrefix<>) . moduleName
   PathIO.writeFile path $ unlines $
      printf "module %s where" (ModuleName.string mainName) :
      "" :
      map (printf "import qualified %s" . prefixed) ms ++
      "" :
      "main :: IO ()" :
      "main = do" :
      indent (map (printf "%s.test" . prefixed) ms)

writeTestModule ::
   (PathClass.AbsRel ar) =>
   Path.Dir ar -> ModuleName.T -> Flags -> Module [Located Pos DocTest] -> IO ()
writeTestModule testDir testPrefix flags m = do
   let path = testDir </> ModuleName.filePath (moduleName m)
   createDirectoryIfMissing True $ Path.takeDirectory path
   PathIO.writeFile path $ formatTestModule testPrefix flags m

formatTestModule ::
   ModuleName.T -> Flags -> Module [Located Pos DocTest] -> String
formatTestModule testPrefix (verbose,importTested) m =
   let escapedPath = show $ Path.toString $ modulePath m
       formatLinePragma loc =
         printf "{-# LINE %d %s #-}" loc escapedPath
       formatPragma (Located loc lns) =
         unlines $
            formatLinePragma loc :
            map
               (\(Located col ln) ->
                  Mn.when (not $ null $ dropWhile isSpace ln)
                    (take col ("{-#" ++ repeat ' ') ++ ln ++ " #-}"))
               lns
       formatImport (Located loc lns) =
         unlines $
            formatLinePragma loc :
            map (\(Located col ln) -> indentRemainder col ln) lns
       isProperty (Located _loc (Property _)) = True; isProperty _ = False
       isExample (Located _loc (Example _ _)) = True; isExample _ = False
       formatTest (Located (loc,col) body) =
         let testCode command mark code =
               (if verbose
                  then [printf " putStrLn %s\n" (show code)] else []) ++
               formatLinePragma loc :
               (' ':command) :
               formatLinePragma loc :
               (replicate (col + length mark) ' ' ++ '(':code++")") :
               []
         in (if verbose
               then printf " putStrLn ('\\n':%s++\":%d:1\")" escapedPath loc
               else printf " putStr \"%s:%d: \""
                        (ModuleName.string $ moduleName m) loc) :
            case body of
               -- ToDo: support custom parameters for quickCheck
               Property prop -> testCode "quickCheck" "prop>" prop
               Example str results ->
                  testCode "docTestExample" ">>>" str ++
                  ("  " ++ showsPrec 11 results "") :
                  []
   in printf
        "-- Do not edit! Automatically created with doctest-extract from %s\n"
        (Path.toString $ modulePath m)
      ++
      foldMap formatPragma (modulePragma m)
      ++
      printf "module %s where\n\n"
         (ModuleName.string $ testPrefix <> moduleName m)
      ++
      Mn.when importTested
         (printf "import %s\n" $ ModuleName.string $ moduleName m)
      ++
      Mn.when (any isExample $ concat $ moduleContent m)
         "import Test.DocTest.Base\n"
      ++
      Mn.when (any isProperty $ concat $ moduleContent m)
         "import Test.QuickCheck (quickCheck)\n\n"
      ++
      foldMap formatImport (moduleSetup m)
      ++
      "\n"
      ++
      "test :: IO ()\n"
      ++
      "test = do\n"
      ++
      (unlines $ concatMap formatTest $ concat $ moduleContent m)