gotyno-hs-1.0.0: src/Library.hs

module Library where

import qualified CodeGeneration.FSharp as FSharp
import qualified CodeGeneration.Python as Python
import qualified CodeGeneration.TypeScript as TypeScript
import qualified Data.Text.IO as TextIO
import qualified Parsing
import RIO
import qualified RIO.Directory as Directory
import qualified RIO.FilePath as FilePath
import qualified RIO.List as List
import qualified RIO.Time as Time
import qualified System.FSNotify as FSNotify
import Types
import Prelude (print, putStrLn)

data OutputDestination
  = SameAsInput
  | OutputPath !FilePath
  | StandardOut
  deriving (Eq, Show)

data Languages = Languages
  { typescript :: !(Maybe OutputDestination),
    fsharp :: !(Maybe OutputDestination),
    python :: !(Maybe OutputDestination)
  }
  deriving (Eq, Show)

data Options = Options
  { languages :: !Languages,
    watchMode :: !Bool,
    verbose :: !Bool,
    inputs :: ![FilePath]
  }
  deriving (Eq, Show)

runMain :: Options -> IO ()
runMain
  Options
    { languages = languages@Languages {typescript, fsharp, python},
      inputs,
      watchMode,
      verbose
    } = do
    when watchMode $ do
      watchInputs inputs languages verbose
    start <- Time.getCurrentTime
    maybeModules <- Parsing.parseModules inputs
    postParsing <- Time.getCurrentTime
    case maybeModules of
      Right modules -> do
        startTS <- Time.getCurrentTime
        forM_ typescript $ outputLanguage modules TypeScript.outputModule "ts"
        endTS <- Time.getCurrentTime
        startFS <- Time.getCurrentTime
        forM_ fsharp $ outputLanguage modules FSharp.outputModule "fs"
        endFS <- Time.getCurrentTime
        startPython <- Time.getCurrentTime
        forM_ python $ outputLanguage modules Python.outputModule "py"
        endPython <- Time.getCurrentTime
        end <- Time.getCurrentTime
        let diff = Time.diffUTCTime end start
            diffParsing = Time.diffUTCTime postParsing start
            diffTS = Time.diffUTCTime endTS startTS
            diffFS = Time.diffUTCTime endFS startFS
            diffPython = Time.diffUTCTime endPython startPython
        when verbose $ do
          putStrLn $ "Parsing took: " <> show diffParsing
          putStrLn $ "Outputting TypeScript took: " <> show diffTS
          putStrLn $ "Outputting FSharp took: " <> show diffFS
          putStrLn $ "Outputting Python took: " <> show diffPython
          putStrLn $ "Entire compilation took: " <> show diff
      Left errors -> forM_ errors putStrLn

outputLanguage :: [Module] -> (Module -> Text) -> FilePath -> OutputDestination -> IO ()
outputLanguage modules outputFunction extension outputDestination = do
  let outputs = modules & fmap outputFunction & zip modules
  case outputDestination of
    StandardOut -> do
      outputs & reverse & forM_ $ \(_module, output) -> TextIO.putStrLn output
    SameAsInput -> do
      forM_ outputs $ \(Module {sourceFile}, output) -> do
        let pathForOutput = FilePath.replaceExtensions sourceFile extension
        writeFileUtf8 pathForOutput output
    OutputPath outputDirectory -> do
      forM_ outputs $ \(Module {sourceFile}, output) -> do
        let pathForOutput =
              FilePath.replaceDirectory sourceFile outputDirectory
                & flip FilePath.replaceExtensions extension
            basePath = FilePath.takeDirectory pathForOutput
        Directory.createDirectoryIfMissing True basePath
        writeFileUtf8 pathForOutput output

watchInputs :: [FilePath] -> Languages -> Bool -> IO ()
watchInputs relativeInputs Languages {typescript, fsharp, python} verbose = do
  inputs <- traverse Directory.makeAbsolute relativeInputs
  let compileEverything = do
        maybeModules <- Parsing.parseModules relativeInputs
        case maybeModules of
          Right modules -> do
            forM_ typescript $ outputLanguage modules TypeScript.outputModule "ts"
            forM_ fsharp $ outputLanguage modules FSharp.outputModule "fs"
            forM_ python $ outputLanguage modules Python.outputModule "py"
          Left errors ->
            forM_ errors putStrLn
      debounceInterval = 0.01 :: Time.NominalDiffTime
      fsNotifyConfig = FSNotify.defaultConfig {FSNotify.confDebounce = FSNotify.Debounce debounceInterval}
  compileEverything
  FSNotify.withManagerConf fsNotifyConfig $ \watchManager -> do
    let inputDirectories = inputs & fmap FilePath.takeDirectory & List.nub
        eventPredicate (FSNotify.Modified modifiedInput _modificationTime _someBool) =
          modifiedInput `elem` inputs
        eventPredicate _otherEvents = False
    forM_ inputDirectories $ \inputDirectory -> do
      putStrLn $ "Watching directory: '" <> inputDirectory <> "'"
      FSNotify.watchDir
        watchManager
        inputDirectory
        eventPredicate
        ( \event -> do
            when verbose (print event)
            compileEverything
        )
    forever $ threadDelay 1000000