]> Git — Sourcephile - doclang.git/blob - cli/Textphile/CLI/Compile.hs
Fix megaparsec-8 update
[doclang.git] / cli / Textphile / CLI / Compile.hs
1 {-# LANGUAGE AllowAmbiguousTypes #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE StrictData #-}
4 {-# OPTIONS_GHC -Wno-missing-signatures #-}
5 module Textphile.CLI.Compile where
6
7 import Control.Applicative (Applicative(..), Alternative(..))
8 import Control.Monad (Monad(..), forM_, unless, when)
9 import Control.Monad.Trans.Except (runExcept)
10 import Control.Monad.Trans.Maybe (MaybeT(..))
11 import Control.Monad.Trans.State.Strict (runState)
12 import Data.Bool
13 import Data.Either (Either(..))
14 import Data.Eq (Eq(..))
15 import Data.Foldable as Foldable (Foldable(..))
16 import Data.Function (($), (.), id, flip)
17 import Data.Functor ((<$>))
18 import Data.Maybe (Maybe(..), fromMaybe)
19 import Data.Ord (Ord(..))
20 import Data.Proxy (Proxy(..))
21 import Data.Semigroup (Semigroup(..))
22 import Data.Text (Text)
23 import Prelude (error)
24 import Symantic.CLI as CLI
25 import System.FilePath ((-<.>), (</>))
26 import System.IO (IO, FilePath)
27 import Text.Show (Show(..))
28 import qualified Data.ByteString as BS
29 import qualified Data.List as List
30 import qualified Data.Text as Text
31 import qualified Data.Text.Lazy as TL
32 import qualified Data.Text.Lazy.IO as TL
33 import qualified Data.TreeSeq.Strict as Tree
34 import qualified Paths_textphile as Textphile
35 import qualified Symantic.Document as Doc
36 import qualified System.Directory as IO
37 import qualified System.Environment as Env
38 import qualified System.FilePath as FP
39 import qualified System.FilePath as FilePath
40 import qualified System.IO as IO
41 import qualified Text.Blaze.DTC as Blaze.DTC
42 import qualified Text.Blaze.HTML5 as Blaze.HTML5
43 import qualified Text.Blaze.Renderer.Utf8 as Blaze
44 import qualified Text.Blaze.Utils as Blaze
45 import qualified Text.Megaparsec as P
46 import qualified Textphile.DTC.Read.TCT as DTC
47 import qualified Textphile.DTC.Sym as DTC
48 import qualified Textphile.DTC.Write.HTML5 as DTC
49 import qualified Textphile.DTC.Write.XML as DTC
50 import qualified Textphile.TCT as TCT
51 import qualified Textphile.TCT.Write.HTML5 as TCT
52 import qualified Textphile.TCT.Write.Plain as TCT
53 import qualified Textphile.TCT.Write.XML as TCT
54 import qualified Textphile.Utils as FS
55
56 import Textphile.CLI.Lang
57 import Textphile.CLI.Utils
58
59 data Cfg_Compile = Cfg_Compile
60 { cfg_compile_dump_tct :: Bool
61 , cfg_compile_dump_xml :: Bool
62 , cfg_compile_dump_deps :: Bool
63 } deriving (Show)
64
65 data Cfg_Compile_HTML5
66 = Cfg_Compile_HTML5
67 { cfg_compile_html5_output_css :: Maybe FP.FilePath
68 , cfg_compile_html5_output_js :: Maybe FP.FilePath
69 , cfg_compile_html5_dump_dtc :: Bool
70 }
71
72 api_command_compile =
73 helps l10n_help_command_compile $
74 command "compile" $
75 (Cfg_Compile
76 <$> api_dump_tct
77 <*> api_dump_xml
78 <*> api_dump_deps
79 )
80 <?> api_format
81 -- <!> api_help False
82 where
83 api_dump_tct =
84 flag "dump-tct"
85 api_dump_xml =
86 flag "dump-xml"
87 api_dump_deps =
88 flag "dump-deps"
89 api_format =
90 api_format_html5 <!>
91 api_format_xml
92 api_output_css =
93 helps l10n_help_opt_output_css $
94 optionalTag "output-css" $
95 var "FILE"
96 api_output_js =
97 helps l10n_help_opt_output_js $
98 optionalTag "output-js" $
99 var "FILE"
100 api_dump_dtc =
101 flag "dump-dtc"
102 api_format_html5 =
103 command "html5" $
104 (Cfg_Compile_HTML5
105 <$> api_output_css
106 <*> api_output_js
107 <*> api_dump_dtc
108 )
109 <?> api_input
110 <.> response @()
111 api_format_xml =
112 command "xml" $
113 api_input
114 <.> response @()
115 api_input =
116 helps l10n_help_opt_input $
117 var @FP.FilePath "INPUT"
118
119 run_command_compile
120 cfg_global@Cfg_Global{..}
121 cfg_compile@Cfg_Compile{..} =
122 run_compile_html5 :!:
123 run_compile_xml
124 where
125 run_compile_dtc cfg_compile_input cfg_compile_output = do
126 outputInfo cfg_global $ "compiling... " <> Doc.from cfg_compile_input
127 TCT.readTCT cfg_compile_input >>= \case
128 Left err -> error $ show err
129 Right tct -> do
130 when cfg_compile_dump_tct $ do
131 FS.writeFile (cfg_compile_output-<.>"tct.dump") $
132 TL.pack $ Tree.prettyTrees tct
133 let xml = TCT.writeXML tct
134 when cfg_compile_dump_xml $ do
135 FS.writeFile (cfg_compile_output-<.>"xml.dump") $
136 TL.pack $ Tree.prettyTrees xml
137 case DTC.readDTC xml of
138 Left err -> do
139 FS.removeFile $ cfg_compile_output-<.>"deps"
140 error $ List.unlines $ Foldable.toList $ P.parseErrorPretty <$> P.bundleErrors err
141 Right dtc -> do
142 when cfg_compile_dump_deps $ do
143 writeDependencies cfg_compile cfg_compile_input tct
144 when cfg_compile_dump_xml $ do
145 FS.writeFile (cfg_compile_output-<.>"dtc.dump") $
146 TL.pack $ show dtc
147 return dtc
148 run_compile_html5 Cfg_Compile_HTML5{..} cfg_compile_input = do
149 let cfg_compile_output = cfg_compile_input-<.>"html5"
150 dtc <- run_compile_dtc cfg_compile_input cfg_compile_output
151 config_css <- installFile cfg_compile_html5_output_css $ "src"</>"style"</>"dtc-html5.css"
152 config_js <- installFile cfg_compile_html5_output_js $ "src"</>"style"</>"dtc-html5.js"
153 let conf = DTC.Config
154 { DTC.config_css
155 , DTC.config_js
156 , DTC.config_locale = cfg_global_lang
157 , DTC.config_generator = TL.fromStrict version
158 }
159 FS.withFile cfg_compile_output IO.WriteMode $ \h -> do
160 html <- DTC.writeHTML5 conf dtc
161 Blaze.prettyMarkupIO
162 Blaze.HTML5.isInlinedElement
163 (BS.hPutStr h)
164 html
165 where
166 installFile out name = do
167 dataDir <- Textphile.getDataDir
168 let src = dataDir</>name
169 case out of
170 Nothing -> Right <$> FS.readFile src
171 Just "" -> return $ Left ""
172 Just dst -> do
173 IO.createDirectoryIfMissing True $ FilePath.takeDirectory dst
174 IO.copyFile src dst
175 return $ Left dst
176 run_compile_xml cfg_compile_input = do
177 let cfg_compile_output = cfg_compile_input-<.>"xml"
178 dtc <- run_compile_dtc cfg_compile_input cfg_compile_output
179 FS.withFile cfg_compile_output IO.WriteMode $ \h ->
180 Blaze.prettyMarkupIO Blaze.DTC.isInlinedElement (BS.hPutStr h) $
181 DTC.writeXML cfg_global_lang dtc
182
183 writeDependencies :: Cfg_Compile -> FilePath -> TCT.Roots -> IO ()
184 writeDependencies Cfg_Compile{..} cfg_compile_input tct =
185 let dir = FilePath.takeDirectory cfg_compile_input in
186 FS.writeFile (cfg_compile_input-<.>"deps") $
187 foldMap (TL.pack . (("\n" <>) . FilePath.normalise))
188 ((dir </>) <$> TCT.dependencies tct) <>
189 "\n"