/
StarterTH.hs
62 lines (50 loc) · 2.04 KB
/
StarterTH.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
{-# LANGUAGE TemplateHaskell #-}
module Snap.StarterTH where
------------------------------------------------------------------------------
import qualified Data.Foldable as F
import Data.List
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import System.Directory.Tree
import System.FilePath
------------------------------------------------------------------------------
------------------------------------------------------------------------------
-- Convenience types
type FileData = (String, String)
type DirData = FilePath
------------------------------------------------------------------------------
-- Gets all the directories in a DirTree
--
getDirs :: [FilePath] -> DirTree a -> [FilePath]
getDirs prefix (Dir n c) = (intercalate "/" (reverse (n:prefix))) :
concatMap (getDirs (n:prefix)) c
getDirs _ (File _ _) = []
getDirs _ (Failed _ _) = []
------------------------------------------------------------------------------
-- Reads a directory and returns a tuple of the list of all directories
-- encountered and a list of filenames and content strings.
--
readTree :: FilePath -> IO ([DirData], [FileData])
readTree dir = do
d <- readDirectory $ dir </> "."
let ps = zipPaths $ "" :/ (free d)
fd = F.foldr (:) [] ps
dirs = getDirs [] $ free d
return (drop 1 dirs, fd)
------------------------------------------------------------------------------
-- Calls readTree and returns its value in a quasiquote.
--
dirQ :: FilePath -> Q Exp
dirQ tplDir = do
d <- runIO . readTree $ "project_template" </> tplDir
lift d
------------------------------------------------------------------------------
-- Creates a declaration assigning the specified name the value returned by
-- dirQ.
--
buildData :: String -> FilePath -> Q [Dec]
buildData dirName tplDir = do
let dir = mkName dirName
typeSig <- SigD dir `fmap` [t| ([String], [(String, String)]) |]
v <- valD (varP dir) (normalB $ dirQ tplDir) []
return [typeSig, v]