descript-lang-0.2.0.0: test/BuildSpec.hs

{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}

-- | Tests all parts of building.
module BuildSpec
       ( spec ) where

import Core.Test
import Descript
import qualified Descript.BasicInj.Data.Value.Reg as BasicInj.Reg
import qualified Descript.BasicInj as BasicInj
import qualified Descript.Sugar as Sugar
import System.FilePath hiding (isValid)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Control.Monad
import Control.Concurrent.MVar

type VarMap k v = Map k (MVar (Maybe v))

examplesDir :: FilePath
examplesDir = "test-resources/examples/"

refactorsDir :: FilePath
refactorsDir = "test-resources/refactors/"

testDepResolver :: DepResolver IO
testDepResolver = defaultResolver examplesDir

getExampleFiles :: IO [TestFile]
getExampleFiles = loadFilesInDir examplesDir

getRefactorText :: String -> String -> IO Text
getRefactorText action = Text.readFile . getRefactorPath action

getRefactorPath :: String -> String -> String
getRefactorPath label' srcName
  = refactorsDir </> srcName <.> label' <.> "dscr"

mkVarMap :: (Ord k) => [k] -> IO (VarMap k v)
mkVarMap = fmap Map.fromList . mapM (sequence . (, newMVar Nothing))

insertVarMap :: (Ord k) => VarMap k v -> k -> v -> IO ()
insertVarMap vars key x = do
  Nothing <- swapMVar (vars Map.! key) $ Just x
  pure ()

spec :: Spec
spec = do
  exampleFiles <- runIO getExampleFiles
  exampleParsedVars <- runIO $ mkVarMap exampleFiles
  exampleResolvedVars <- runIO $ mkVarMap exampleFiles
  exampleRefinedVars <- runIO $ mkVarMap exampleFiles
  exampleInterpretedVars <- runIO $ mkVarMap exampleFiles
  let forExampleFile :: (TestFile -> IO ()) -> IO ()
      forExampleFile f =
        forM_ exampleFiles $ \file ->
          denoteFailIn ("file " ++ sfileName (srcFile file)) $ f file
      forPhaseIn :: TestFile -> (String -> ParseResult (String, String) -> IO ()) -> IO ()
      forPhaseIn file@(TestFile srcFile' _) f = do
        result <- runResultT $ parseTest srcFile' $ \phaseName phaseRes ->
          denoteFailIn ("phase " ++ phaseName) $ f phaseName phaseRes
        case result of
          Failure _ -> pure ()
          Success val -> insertVarMap exampleParsedVars file val
      forExampleIntermediateIn :: Map TestFile (MVar (Maybe a)) -> (TestFile -> a -> IO ()) -> IO ()
      forExampleIntermediateIn xVars f =
        forM_ (Map.toAscList xVars) $ \(file, xVar) ->
          denoteFailIn ("file " ++ sfileName (srcFile file)) $ withMVar xVar $ \case
            Nothing -> pure ()
            Just val -> f file val
      forExampleParsed :: (TestFile -> Sugar.Source SrcAnn -> IO ()) -> IO ()
      forExampleParsed = forExampleIntermediateIn exampleParsedVars
      forExampleResolved :: (TestFile -> BasicInj.DirtyDepd Sugar.Source SrcAnn -> IO ()) -> IO ()
      forExampleResolved = forExampleIntermediateIn exampleResolvedVars
      forExampleRefinedSrc :: (TestFile -> BasicInj.DirtyDepd BasicInj.Source SrcAnn -> IO ()) -> IO ()
      forExampleRefinedSrc = forExampleIntermediateIn exampleRefinedVars
      forExampleRefinedProg :: (TestFile -> BasicInj.DirtyDepd BasicInj.Program SrcAnn -> IO ()) -> IO ()
      forExampleRefinedProg f = forExampleRefinedSrc $ \file -> \case
        Depd _ (BasicInj.SourceModule _) -> pure ()
        Depd ddep (BasicInj.SourceProgram prgm) -> f file $ Depd ddep prgm
      forExampleInterpreted :: (TestFile -> BasicInj.Reg.Value () -> IO ()) -> IO ()
      forExampleInterpreted = forExampleIntermediateIn exampleInterpretedVars

  describe "Read" $ do
    it "Parses" $
      forExampleFile $ \file@(TestFile srcFile' testInfo') -> do
        let shouldFailTo = shouldFailToSummaryIn srcFile'
            fileStr = Text.unpack $ sfileContents srcFile'
        if isParseable testInfo' then do
          forPhaseIn file $ \phaseName phaseRes -> do
            when (phaseName `elem` printParsedPhases testInfo') $ do
              putStrLn $ sfileName srcFile' ++ " - " ++ phaseName ++ ":"
              putStrLn $ summaryF srcFile' phaseRes
            case phaseRes of
              Failure phaseErr -> assertFailure $ summaryF srcFile' phaseErr
              Success (phaseRp, _) -> phaseRp `shouldBeReducePrintOf` fileStr
        else
          unless (null $ errorMsg testInfo') $ do
            parse srcFile' `shouldFailTo` errorMsg testInfo'
    it "Resolves" $
      -- Dependency failures are handled by the validation tests.
      forExampleParsed $ \file@(TestFile srcFile' testInfo') psrc -> do
        rsddsrc <- Sugar.resolve testDepResolver psrc
        when (printDependency testInfo') $ do
          let dep = dirtyVal $ depdDep rsddsrc
          putStrLn $ sfileName srcFile' ++ ":"
          Text.putStrLn $ pprint dep
        insertVarMap exampleResolvedVars file rsddsrc
    it "Refines" $
      -- This test is only useful to check hanging and exceptions.
      -- Not sure if it even does that because the source isn't forced.
      forExampleResolved $ \file rsddsrc -> do
        let !rfddsrc = Sugar.refineDDepd rsddsrc
        insertVarMap exampleRefinedVars file rfddsrc
  describe "Process" $ do
    it "Validates" $
      forExampleRefinedSrc $ \(TestFile _ testInfo') ddsrc -> do
        let pmsgs = map summary $ BasicInj.validate' ddsrc
        if isValid testInfo' then
          pmsgs `shouldSatisfy` null
        else
          unless (null $ problemMsgs testInfo') $ do
            pmsgs `shouldBe` problemMsgs testInfo'
    it "Interprets" $
      forExampleRefinedProg $ \file@(TestFile _ testInfo') ddprog ->
        when (isValid testInfo' && isTerminating testInfo') $ do
          let dprog = mapDep dirtyVal ddprog
              !interpreted = BasicInj.interpret_ dprog
          insertVarMap exampleInterpretedVars file interpreted
    it "Refactors" $
      forExampleFile $ \(TestFile srcFile' testInfo') -> do
        let srcDFile = DFile testDepResolver srcFile'
            srcText' = sfileContents srcFile'
        forM_ (refactorCmds testInfo') $ \(RefactorInfo action args ewarnMsgs eerrMsg label') -> do
          let shouldSucceed = null eerrMsg
          Dirty awarnings res <- runDirtyResT $ parseRefactor action args srcDFile
          let awarnMsgs = map summary awarnings
          case res of
            Failure err -> do
              let aerrMsg = summaryF srcFile' err
              if shouldSucceed then
                assertFailure aerrMsg
              else
                aerrMsg `shouldBe` eerrMsg
            Success patch -> do
              let anewSrcText = apPatch patch srcText'
              if shouldSucceed then do
                enewSrcText <- getRefactorText label' $ sfileName srcFile'
                anewSrcText `shouldBe` enewSrcText
              else
                assertFailure $ "Unexpected success\n" ++ Text.unpack anewSrcText
          awarnMsgs `shouldBe` ewarnMsgs
  describe "Write" $ do
    it "Compiles" $
      forExampleInterpreted $ \(TestFile srcFile' testInfo') interpreted ->
        when (isFinal testInfo') $
          case BasicInj.compile (sfileName srcFile') interpreted of
            Failure err -> assertFailure $ summary err
            Success package -> do
              when (printCompiled testInfo') $ do
                putStrLn $ sfileName srcFile' ++ ":"
                Text.putStrLn $ pprintPackage package
              unless (Text.null $ packagePr testInfo') $
                pprintPackage package `shouldBe` packagePr testInfo'
    it "Evaluates" $
      forExampleInterpreted $ \(TestFile srcFile' testInfo') interpreted -> do
        when (printEvaluated testInfo') $ do
          putStr $ sfileName srcFile' ++ ": "
          Text.putStrLn $ pprint interpreted
        unless (Text.null $ evalPr testInfo') $
          pprint interpreted `shouldBe` evalPr testInfo'
    it "Reprints" $
      forExampleRefinedSrc $ \(TestFile srcFile' testInfo') dsrc -> do
        let source = depdVal dsrc
            srcText' = sfileContents srcFile'
            patch = ppatchThorough source
        when (printReprinted testInfo') $ do
          putStrLn $ sfileName srcFile' ++ ": "
          Text.putStrLn $ reprint (sfileContents srcFile') source
        reprint srcText' source `shouldSatisfy` (`Text.isInfixOf` srcText')
        apPatch patch srcText' `shouldBe` srcText'
        patchOffset patch `shouldBe` mempty