diff --git a/Scaffold/Build.hs b/Scaffold/Build.hs new file mode 100644 index 00000000..7e35b669 --- /dev/null +++ b/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) diff --git a/scaffold.hs b/scaffold.hs index 1bf4b627..8337a58d 100644 --- a/scaffold.hs +++ b/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 " + 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 diff --git a/yesod.cabal b/yesod.cabal index c4782011..391bbfda 100644 --- a/yesod.cabal +++ b/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