yesod build

Scaffold/Build.hs

@@ -0,0 +1,118 @@
+{-# 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)

scaffold.hs

@@ -11,6 +11,9 @@ import qualified Data.ByteString.Lazy as L
 import qualified Data.Text.Lazy as LT
 import qualified Data.Text.Lazy.Encoding as LT
 import Control.Monad (when, unless)
+import System.Environment (getArgs)
+
+import Scaffold.Build
 
 qq :: String
 #if __GLASGOW_HASKELL__ >= 700
@@ -30,6 +33,18 @@ prompt f = do
 
 main :: IO ()
 main = do
+    args <- getArgs
+    case args of
+        ["init"] -> scaffold
+        ["build"] -> build
+        _ -> do
+            putStrLn "Usage: yesod <command>"
+            putStrLn "Available commands:"
+            putStrLn "    init         Scaffold a new site"
+            putStrLn "    build        Build project (performs TH dependency analysis)"
+
+scaffold :: IO ()
+scaffold = do
     putStr $(codegen "welcome")
     hFlush stdout
     name <- getLine

yesod.cabal

@@ -53,10 +53,14 @@ executable             yesod
                      , time               >= 1.1.4        && < 1.3
                      , template-haskell
                      , directory          >= 1.0          && < 1.2
+                     , Cabal              >= 1.8          && < 1.11
+                     , unix-compat        >= 0.2          && < 0.3
+                     , containers         >= 0.2          && < 0.5
+                     , attoparsec-text    >= 0.8.5        && < 0.9
     ghc-options:       -Wall
     main-is:           scaffold.hs
     other-modules:     CodeGen
-    extensions:        TemplateHaskell
+                       Scaffold.Build
     if flag(ghc7)
         cpp-options:     -DGHC7