Spec.hs

{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

module Language.PureScript.Backend.Lua.Golden.Spec where

import Control.Monad.Catch (MonadMask)
import Control.Monad.Oops qualified as Oops
import Data.List qualified as List
import Data.String qualified as String
import Data.Tagged (Tagged (..))
import Data.Text qualified as Text
import Language.PureScript.Backend.IR qualified as IR
import Language.PureScript.Backend.IR.Linker (LinkMode (..))
import Language.PureScript.Backend.IR.Linker qualified as IR
import Language.PureScript.Backend.IR.Linker qualified as Linker
import Language.PureScript.Backend.IR.Optimizer (optimizedUberModule)
import Language.PureScript.Backend.Lua qualified as Lua
import Language.PureScript.Backend.Lua.Optimizer (optimizeChunk)
import Language.PureScript.Backend.Lua.Printer qualified as Printer
import Language.PureScript.Backend.Types (AppOrModule (..))
import Language.PureScript.CoreFn.Reader qualified as CoreFn
import Language.PureScript.Names qualified as PS
import Path
  ( Abs
  , Dir
  , File
  , Path
  , Rel
  , SomeBase (..)
  , dirname
  , filename
  , mkRelDir
  , parent
  , reldir
  , toFilePath
  , (</>)
  )
import Path.IO
  ( AnyPath (makeRelativeToCurrentDir)
  , doesFileExist
  , ensureDir
  , makeAbsolute
  , walkDirAccum
  , withCurrentDir
  )
import Path.Posix (mkRelFile)
import Prettyprinter (defaultLayoutOptions, layoutPretty)
import Prettyprinter.Render.Text (renderStrict)
import System.FilePath qualified as FilePath
import System.Process.Typed
  ( ExitCode (..)
  , readProcessInterleaved
  , runProcess
  , setWorkingDir
  , shell
  )
import Test.Hspec
  ( Spec
  , beforeAll_
  , describe
  , it
  , runIO
  , shouldBe
  , shouldNotBe
  )
import Test.Hspec.Extra (annotatingWith)
import Test.Hspec.Golden (defaultGolden)
import Text.Pretty.Simple
  ( OutputOptions (..)
  , defaultOutputOptionsNoColor
  , pShowOpt
  )

spec ∷ Spec
spec = do
  describe "Goldens: *.purs -> *.lua" do
    let compilePs = do
          putText "Compiling PureScript sources"
          exitCode ←
            runProcess . setWorkingDir "test/ps" . shell $
              String.unwords ["spago", "build"]
          exitCode `shouldBe` ExitSuccess
        psOutputPath = $(mkRelDir "test/ps/output/")

    describe "compiles corefn files to lua" $ beforeAll_ compilePs do
      runIO $ ensureDir psOutputPath
      corefns ← runIO $ collectGoldenCorefns psOutputPath
      it "Finds some corefn files" $ corefns `shouldNotBe` mempty
      for_ corefns \corefn → do
        let modulePath = parent corefn
            moduleName =
              PS.ModuleName
                . toText
                . FilePath.dropTrailingPathSeparator
                . toFilePath
                $ dirname modulePath
        -- IR golden
        let irGolden = modulePath </> $(mkRelFile "golden.ir")
        let irActual = modulePath </> $(mkRelFile "actual.ir")
        irTestName ← runIO do
          toFilePath <$> makeRelativeToCurrentDir irGolden
        it irTestName do
          defaultGolden irGolden (Just irActual) do
            uberModule ← compileCorefn (Tagged (Rel psOutputPath)) moduleName
            pure . toStrict $
              pShowOpt
                defaultOutputOptionsNoColor
                  { outputOptionsIndentAmount = 2
                  , outputOptionsPageWidth = 100
                  , outputOptionsCompact = True
                  }
                uberModule
        -- lua golden
        let evalGolden =
              modulePath </> $(mkRelDir "eval") </> $(mkRelFile "golden.txt")
        let luaGolden = modulePath </> $(mkRelFile "golden.lua")
        let luaActual = modulePath </> $(mkRelFile "actual.lua")
        luaTestName ← runIO do
          toFilePath <$> makeRelativeToCurrentDir luaGolden
        it luaTestName do
          defaultGolden luaGolden (Just luaActual) do
            appOrModule ←
              (doesFileExist evalGolden) <&> \case
                True → AsApplication moduleName (PS.Ident "main")
                False → AsModule moduleName
            cfn ← compileCorefn (Tagged (Rel psOutputPath)) moduleName
            compileIr appOrModule cfn

    describe "golden files should evaluate" do
      let
        collectEvaluatableLuas ∷ MonadIO m ⇒ Path Rel Dir → m [Path Abs File]
        collectEvaluatableLuas = walkDirAccum Nothing \_dir _subdirs files →
          pure [file | file ← files, toFilePath (filename file) == "golden.txt"]

      luas ← runIO do collectEvaluatableLuas psOutputPath
      for_ luas \lua → do
        let evalDir = parent lua
        let resActual = evalDir </> $(mkRelFile "actual.txt")
        let resGolden = evalDir </> $(mkRelFile "golden.txt")
        let luaGolden = parent evalDir </> $(mkRelFile "golden.lua")
        luaTestName ← runIO do makeRelativeToCurrentDir lua
        it (toFilePath luaTestName) do
          defaultGolden resGolden (Just resActual) do
            let process = fromString $ "lua " ++ toFilePath luaGolden
            (exitCode, out) ← readProcessInterleaved process
            let niceOut =
                  decodeUtf8 out
                    & lines
                    & fmap Text.stripStart
                    & filter (not . Text.null)
                    & unlines
                    & toString
            exitCode `shouldBe` ExitSuccess `annotatingWith` niceOut
            pure $ toText niceOut

    describe "golden files should typecheck" do
      luas ← runIO do collectLuas psOutputPath
      for_ luas \lua → do
        luaFileName ← runIO do makeRelativeToCurrentDir lua
        it (toFilePath luaFileName) do
          let process =
                fromString . List.unwords $
                  [ "luacheck"
                  , "--quiet"
                  , "--std min"
                  , "--no-color"
                  , "--no-unused" -- TODO: harden eventually
                  , "--no-max-line-length"
                  , "--formatter plain"
                  , "--allow-defined"
                  , toFilePath lua
                  ]
          (exitCode, out) ← readProcessInterleaved process
          let niceOut =
                decodeUtf8 out
                  & lines
                  & fmap Text.stripStart
                  & filter (not . Text.null)
                  & unlines
                  & toString
          exitCode `shouldBe` ExitSuccess `annotatingWith` niceOut

collectGoldenCorefns ∷ MonadIO m ⇒ Path Rel Dir → m [Path Abs File]
collectGoldenCorefns = walkDirAccum
  Nothing -- Descend into every directory
  \dir _subdirs files →
    pure
      [ file
      | file ← files
      , toFilePath (filename file) == "corefn.json"
      , "Golden." `isPrefixOf` toFilePath (dirname dir)
      ]

collectLuas ∷ MonadIO m ⇒ Path Rel Dir → m [Path Abs File]
collectLuas = walkDirAccum
  Nothing -- Descend into every directory
  \_dir _subdirs files →
    pure [file | file ← files, toFilePath (filename file) == "golden.lua"]

compileCorefn
  ∷ ∀ m
   . (MonadIO m, MonadFail m)
  ⇒ Tagged "output" (SomeBase Dir)
  → PS.ModuleName
  → m IR.UberModule
compileCorefn outputDir uberModuleName = do
  cfnModules ←
    CoreFn.readModuleRecursively outputDir uberModuleName
      & handleModuleNotFoundError
      & handleModuleDecodingError
      & Oops.runOops
      & liftIO

  let dataDecls = IR.collectDataDeclarations cfnModules
  modules ←
    forM (toList cfnModules) $
      either (fail . show) (pure . snd) . (`IR.mkModule` dataDecls)
  let uberModule = Linker.makeUberModule (LinkAsModule uberModuleName) modules
  pure $ optimizedUberModule uberModule

compileIr ∷ (MonadIO m, MonadMask m) ⇒ AppOrModule → IR.UberModule → m Text
compileIr appOrModule uberModule = withCurrentDir [reldir|test/ps|] do
  foreignPath ← Tagged <$> makeAbsolute [reldir|foreign|]
  luaChunk ←
    Lua.fromUberModule foreignPath (Tagged True) appOrModule uberModule
      & handleLuaError
      & Oops.runOops
      & liftIO

  let doc =
        luaChunk
          & optimizeChunk
          & Printer.printLuaChunk
  let addTrailingLf = (<> "\n")
  pure $ addTrailingLf $ renderStrict $ layoutPretty defaultLayoutOptions doc

--------------------------------------------------------------------------------
-- Error handlers --------------------------------------------------------------

handleModuleNotFoundError
  ∷ ExceptT (Oops.Variant (CoreFn.ModuleNotFound ': e)) IO a
  → ExceptT (Oops.Variant e) IO a
handleModuleNotFoundError = Oops.catch \(CoreFn.ModuleNotFound p) →
  die . toString . unlines $
    [ "Can't find CoreFn module file: " <> toText (toFilePath p)
    , "Please make sure you did run purs with the `-g corefn` arg."
    ]

handleModuleDecodingError
  ∷ ExceptT (Oops.Variant (CoreFn.ModuleDecodingErr ': e)) IO a
  → ExceptT (Oops.Variant e) IO a
handleModuleDecodingError = Oops.catch \(CoreFn.ModuleDecodingErr p e) →
  die . toString . unlines $
    ["Can't parse CoreFn module file: " <> toText (toFilePath p), toText e]

handleLuaError
  ∷ ExceptT (Oops.Variant (Lua.Error ': e)) IO a
  → ExceptT (Oops.Variant e) IO a
handleLuaError = Oops.catch \(e ∷ Lua.Error) → die $ show e