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"