typed-wire-0.3.1.0: app/Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}
module Main where

import TW.Ast
import TW.Check
import qualified TW.CodeGen.Elm as Elm
import qualified TW.CodeGen.Haskell as HS
import qualified TW.CodeGen.PureScript as PS
import TW.Loader
import TW.Parser
import TW.Types

import qualified Paths_typed_wire as Meta

import Control.Monad (forM_)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Version as Vers
import Development.GitRev
import Options.Applicative
import System.Directory
import System.FilePath

data Options
   = Options
   { o_showVersion :: Bool
   , o_sourceDirs  :: [FilePath]
   , o_entryPoints :: [ModuleName]
   , o_hsOutDir    :: Maybe FilePath
   , o_elmOutDir   :: Maybe FilePath
   , o_psOutDir    :: Maybe FilePath
   }

optParser :: Parser Options
optParser =
    Options
    <$> switch (long "version" <> help "Show version and exit")
    <*> sourceDirsP
    <*> entryPointsP
    <*> hsOutP
    <*> elmOutP
    <*> psOutP

sourceDirsP :: Parser [FilePath]
sourceDirsP =
    many $ strOption $
    long "include-dir" <> short 'i' <> metavar "DIR" <> help "Directory to search for modules"

entryPointsP :: Parser [ModuleName]
entryPointsP =
    many $ option (str >>= mkMod) $
    long "entrypoint" <> short 'e' <> metavar "MODULE-NAME" <> help "Entrypoint for compiler"
    where
      mkMod t =
          case makeModuleName (T.pack t) of
            Left _ -> fail $ "Can not parse " ++ t ++ " as module"
            Right x -> return x

hsOutP :: Parser (Maybe FilePath)
hsOutP =
    optional $ strOption $
    long "hs-out" <> metavar "DIR" <> help "Generate Haskell bindings to specified dir"

elmOutP :: Parser (Maybe FilePath)
elmOutP =
    optional $ strOption $
    long "elm-out" <> metavar "DIR" <> help "Generate Elm bindings to specified dir"

psOutP :: Parser (Maybe FilePath)
psOutP =
    optional $ strOption $
    long "purescript-out" <> metavar "DIR" <> help "Generate PureScript bindings to specified dir"

main :: IO ()
main =
    execParser opts >>= run
    where
      opts =
          info (helper <*> optParser)
          ( fullDesc
          <> progDesc "Language-independent type-safe communication"
          <> header "Generate bindings using typed-wire for different languages"
          )

showVersion :: IO ()
showVersion =
    T.putStrLn versionMessage
    where
      versionMessage =
          T.unlines
          [ "Version " <> T.pack (Vers.showVersion Meta.version)
          , "Git: " <> $(gitBranch) <> "@" <> $(gitHash)
          , " (" <> $(gitCommitCount) <> " commits in HEAD)"
          , if $(gitDirty) then " (includes uncommited changes)" else ""
          ]

run :: Options -> IO ()
run opts =
    if o_showVersion opts
    then showVersion
    else run' opts

run' :: Options -> IO ()
run' opts =
    do allModules <- loadModules (o_sourceDirs opts) (o_entryPoints opts)
       putStrLn "All modules loaded"
       case allModules of
         Left err -> fail err
         Right ok ->
             case checkModules ok of
               Left err -> fail err
               Right readyModules ->
                 do
                   forM_ (o_hsOutDir opts) $ \dir ->
                     do printLibraryInfo HS.libraryInfo
                        mapM_ (runner dir HS.makeModule HS.makeFileName) readyModules
                   forM_ (o_elmOutDir opts) $ \dir ->
                     do printLibraryInfo Elm.libraryInfo
                        mapM_ (runner dir Elm.makeModule Elm.makeFileName) readyModules
                   forM_ (o_psOutDir opts) $ \dir ->
                     do printLibraryInfo PS.libraryInfo
                        mapM_ (runner dir PS.makeModule PS.makeFileName) readyModules
                   return ()

printLibraryInfo :: LibraryInfo -> IO ()
printLibraryInfo li = T.putStrLn $
    "Required " <> li_type li <> " " <>
    li_name li <> " version " <> li_version li

runner :: FilePath -> (Module -> T.Text) -> (ModuleName -> FilePath) -> Module -> IO ()
runner baseDir mkModule mkFilename m =
    let moduleSrc = mkModule m
        moduleFp = baseDir </> mkFilename (m_name m)
    in do createDirectoryIfMissing True (takeDirectory moduleFp)
          putStrLn $ "Writing " ++ moduleFp ++ " ..."
          T.writeFile moduleFp moduleSrc