{-# LANGUAGE OverloadedStrings #-}
module Scaffold.Build
    ( build
    ) where

import qualified Distribution.Simple.Build as B
import Distribution.PackageDescription.Parse
import Distribution.Verbosity (normal)
import System.Directory (getDirectoryContents, doesDirectoryExist)
import Data.List (isSuffixOf)
import Distribution.PackageDescription (packageDescription)
import Distribution.Simple.Utils (defaultPackageDesc, defaultHookedPackageDesc)
import Distribution.Simple.Setup (defaultBuildFlags)
import Distribution.Simple.Configure (getPersistBuildConfig, localBuildInfoFile)
import Distribution.Simple.LocalBuildInfo
import qualified Data.Attoparsec.Text.Lazy as A
import qualified Data.Text.Lazy.IO as TIO
import Control.Applicative ((<|>))
import Data.Char (isSpace)
import Data.Maybe (mapMaybe)
import Data.Monoid (mappend)
import qualified Data.Map as Map
import qualified Data.Set as Set
import System.PosixCompat.Files (accessTime, modificationTime, getFileStatus, setFileTimes)

build :: IO ()
build = do
    {-
    cabal <- defaultPackageDesc normal
    gpd <- readPackageDescription normal cabal
    putStrLn $ showPackageDescription $ packageDescription gpd
    -}
    hss <- findHaskellFiles "."
    deps' <- mapM determineHamletDeps hss
    let deps = fixDeps $ zip hss deps'
    touchDeps deps

    lbi <- getPersistBuildConfig "dist"
    B.build
        (localPkgDescr lbi)
        lbi
        defaultBuildFlags
        []

type Deps = Map.Map FilePath (Set.Set FilePath)

touchDeps :: Deps -> IO ()
touchDeps =
    mapM_ go . Map.toList
  where
    go (x, ys) = do
        fs <- getFileStatus x
        flip mapM_ (Set.toList ys) $ \y -> do
            fs' <- getFileStatus y
            if modificationTime fs' < modificationTime fs
                then do
                    putStrLn $ "Touching " ++ y ++ " because of " ++ x
                    setFileTimes y (accessTime fs') (modificationTime fs)
                else return ()

fixDeps :: [(FilePath, [FilePath])] -> Deps
fixDeps =
    Map.unionsWith mappend . map go
  where
    go :: (FilePath, [FilePath]) -> Deps
    go (x, ys) = Map.fromList $ map (\y -> (y, Set.singleton x)) ys

findHaskellFiles :: FilePath -> IO [FilePath]
findHaskellFiles path = do
    contents <- getDirectoryContents path
    fmap concat $ mapM go contents
  where
    go ('.':_) = return []
    go "dist" = return []
    go x = do
        let y = path ++ '/' : x
        d <- doesDirectoryExist y
        if d
            then findHaskellFiles y
            else if ".hs" `isSuffixOf` x || ".lhs" `isSuffixOf` x
                    then return [y]
                    else return []

data TempType = Hamlet | Cassius | Lucius | Julius | Widget | Verbatim
    deriving Show

determineHamletDeps :: FilePath -> IO [FilePath]
determineHamletDeps x = do
    y <- TIO.readFile x
    let z = A.parse (A.many $ (parser <|> (A.anyChar >> return Nothing))) y
    case z of
        A.Fail{} -> return []
        A.Done _ r -> return $ mapMaybe go r
  where
    go (Just (Hamlet, f)) = Just $ "hamlet/" ++ f ++ ".hamlet"
    go (Just (Widget, f)) = Just $ "hamlet/" ++ f ++ ".hamlet"
    go (Just (Verbatim, f)) = Just f
    go _ = Nothing
    parser = do
        ty <- (A.string "$(hamletFile " >> return Hamlet)
           <|> (A.string "$(cassiusFile " >> return Cassius)
           <|> (A.string "$(luciusFile " >> return Lucius)
           <|> (A.string "$(juliusFile " >> return Julius)
           <|> (A.string "$(widgetFile " >> return Widget)
           <|> (A.string "$(Settings.hamletFile " >> return Hamlet)
           <|> (A.string "$(Settings.cassiusFile " >> return Cassius)
           <|> (A.string "$(Settings.luciusFile " >> return Lucius)
           <|> (A.string "$(Settings.juliusFile " >> return Julius)
           <|> (A.string "$(Settings.widgetFile " >> return Widget)
           <|> (A.string "$(persistFile " >> return Verbatim)
           <|> (A.string "$(parseRoutesFile " >> return Verbatim)
        A.skipWhile isSpace
        _ <- A.char '"'
        y <- A.many1 $ A.satisfy (/= '"')
        _ <- A.char '"'
        A.skipWhile isSpace
        _ <- A.char ')'
        return $ Just (ty, y)