never executed always true always false
1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE QuasiQuotes #-}
3 {-# LANGUAGE NoMonomorphismRestriction #-}
4
5 {-# OPTIONS -fno-warn-orphans #-}
6
7 {- |
8 Module : NITTA.Project.Template
9 Description : Generate target project by specific templates
10 Copyright : (c) Aleksandr Penskoi, 2021
11 License : BSD3
12 Maintainer : aleksandr.penskoi@gmail.com
13 Stability : experimental
14 -}
15 module NITTA.Project.Template (
16 writeRenderedTemplates,
17 collectNittaPath,
18 projectContext,
19 ) where
20
21 -- TODO: Fix imports inside template
22
23 import Control.Exception
24 import Control.Monad.Identity (runIdentity)
25 import Data.Aeson
26 import Data.Default
27 import Data.Foldable
28 import Data.HashMap.Strict qualified as M
29 import Data.Hashable
30 import Data.Maybe
31 import Data.String.Interpolate
32 import Data.Text qualified as T
33 import Data.Text.IO qualified as T
34 import GHC.Generics hiding (moduleName)
35 import NITTA.Project.Context
36 import NITTA.Project.Types
37 import System.Directory
38 import System.FilePath
39 import System.Log.Logger
40 import System.Path.WildMatch
41 import Text.Ginger
42 import Text.Toml
43
44 data Conf = Conf
45 { template :: TemplateConf
46 , signals :: M.HashMap T.Text T.Text
47 }
48 deriving (Show)
49
50 data TemplateConf = TemplateConf
51 { nittaPath :: Maybe FilePath
52 , ignore :: Maybe [FilePath]
53 }
54 deriving (Generic, Show)
55
56 defNittaPath = "."
57 templateConfFileName = "template.toml"
58
59 instance Default TemplateConf where
60 def =
61 TemplateConf
62 { nittaPath = Just defNittaPath
63 , ignore = Just [templateConfFileName]
64 }
65
66 instance Hashable k => Default (M.HashMap k v) where
67 def = M.fromList []
68
69 instance FromJSON TemplateConf
70 instance ToJSON TemplateConf
71
72 {- | collectNittaPath - read nittaPath from all provided target templates and
73 return it if all of them are the same.
74 -}
75 collectNittaPath :: [FilePath] -> IO (Either T.Text FilePath)
76 collectNittaPath templates = do
77 paths <- mapM (\fn -> (fn,) . getNittaPath <$> readTemplateConfDef (fn </> templateConfFileName)) templates
78 let path = if null paths then defNittaPath else snd $ head paths
79 err =
80 "inconsistency of nittaPath: "
81 <> T.intercalate ", " (map (\(f, p) -> [i|#{f} -> '#{p}'|]) paths)
82 return $
83 if all ((== path) . snd) paths
84 then Right path
85 else Left err
86 where
87 getNittaPath = fromMaybe (error "internal error") . nittaPath . template
88
89 readTemplateConfDef fn = do
90 text <-
91 doesFileExist fn >>= \case
92 True -> T.readFile fn
93 False -> return ""
94 let conf = either (error . show) id $ parseTomlDoc (fn <> ": parse error: ") text
95 return
96 Conf
97 { template = confLookup fn "template" conf
98 , signals = confLookup fn "signals" conf
99 }
100
101 confLookup fn sec conf =
102 maybe
103 def
104 (unwrap (fn <> " in section [" <> T.unpack sec <> "]: ") . fromJSON . toJSON)
105 $ M.lookup sec conf
106 where
107 unwrap _prefix (Success a) = a
108 unwrap prefix (Error msg) = error $ prefix <> msg
109
110 applyCustomSignal
111 signals
112 env@UnitEnv{sigClk, sigRst} =
113 env
114 { sigClk = fromMaybe sigClk $ M.lookup "clk" signals
115 , sigRst = fromMaybe sigRst $ M.lookup "rst" signals
116 -- , sigCycleBegin = fromMaybe sigCycleBegin $ M.lookup "cycleBegin" signals
117 -- , sigInCycle = fromMaybe sigInCycle $ M.lookup "inCycle" signals
118 -- , sigCycleEnd = fromMaybe sigCycleEnd $ M.lookup "cycleEnd" signals
119 }
120
121 writeRenderedTemplates prj@Project{pTargetProjectPath, pTemplates, pUnitEnv} = do
122 createDirectoryIfMissing True pTargetProjectPath
123 for_ pTemplates $ \tPath -> do
124 infoM "NITTA" $ "process template: " <> tPath
125 Conf
126 { template = TemplateConf{ignore}
127 , signals
128 } <-
129 readTemplateConfDef $ tPath </> templateConfFileName
130 let notIgnored fn = not $ all (\wc -> wildCheckCase wc fn) $ fromMaybe [] ignore
131 context = projectContext $ prj{pUnitEnv = applyCustomSignal signals pUnitEnv}
132 tFiles <- filter notIgnored <$> findAllFiles tPath
133 for_ tFiles $ \tFile -> do
134 writeRendedTemplate context pTargetProjectPath tPath tFile
135
136 writeRendedTemplate context opath tPath tFile = do
137 -- Why we use Text and unpack it immidiatly? We need to avoid lazyness.
138 try (T.readFile $ tPath </> tFile) >>= \case
139 Left (e :: IOException) ->
140 warningM "NITTA" $ "template problem SKIP: " <> show e
141 Right src -> writeRendedTemplate' context opath tPath tFile $ T.unpack src
142
143 writeRendedTemplate' context opath tPath tFile src = do
144 let raiseError err = error $ tPath </> tFile <> ": " <> formatParserError (Just src) err
145 template <-
146 either raiseError return <$> runIdentity $
147 parseGinger (const $ return Nothing) Nothing src
148 createDirectoryIfMissing True $ opath </> takeDirectory tFile
149 T.writeFile (opath </> tFile) $ runGinger context template
150
151 -- | List all files inside path
152 findAllFiles root = findAllFiles' ""
153 where
154 findAllFiles' path = do
155 items <- map (path </>) <$> listDirectory (root </> path)
156 concat
157 <$> mapM
158 ( \item -> do
159 isDir <- doesDirectoryExist (root </> item)
160 if isDir
161 then findAllFiles' item
162 else return [item]
163 )
164 items