Util.hs

{-# LANGUAGE CPP               #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE ViewPatterns      #-}

module Dhall.Test.Util
    ( code
    , codeWith
    , equivalent
    , load
    , loadRelativeTo
    , loadWith
    , normalize'
    , normalizeWith'
    , assertNormalizesTo
    , assertNormalizesToWith
    , assertNormalized
    , assertTypeChecks
    , assertDoesntTypeCheck
    , discover
    , Dhall.Test.Util.testCase
    , toDhallPath
    , managedTestEnvironment
    ) where

import Control.Applicative              (liftA2, (<|>))
import Control.Exception                (tryJust)
import Control.Monad                    (guard)
import Control.Monad.Trans.State.Strict (StateT)
import Data.Bifunctor                   (first)
import Data.Text                        (Text)
import Data.Void                        (Void)
import Dhall.Context                    (Context)
import Dhall.Core
    ( Chunks (..)
    , Expr (..)
    , Import
    , Normalizer
    , ReifiedNormalizer (..)
    )
import Dhall.Import                     (SemanticCacheMode (..), Status (..))
import Dhall.Parser                     (Src)
import Prelude                          hiding (FilePath)
import System.IO.Error                  (isDoesNotExistError)
import Test.Tasty                       (TestTree)
import Test.Tasty.HUnit
import Turtle                           (FilePath, Pattern, Shell, fp)

import qualified Control.Exception
import qualified Control.Foldl                    as Foldl
import qualified Control.Monad.Trans.State.Strict as State
import qualified Data.Functor
import qualified Data.Text                        as Text
import qualified Data.Text.IO                     as Text.IO
import qualified Dhall.Context
import qualified Dhall.Core
import qualified Dhall.Import
import qualified Dhall.Map
import qualified Dhall.Parser
import qualified Dhall.TypeCheck
import qualified System.FilePath                  as FilePath
import qualified Test.Tasty                       as Tasty
import qualified Test.Tasty.ExpectedFailure       as Tasty.ExpectedFailure
import qualified Turtle

#if defined(WITH_HTTP) && defined(NETWORK_TESTS)
import qualified Data.Foldable
#else
import Control.Monad.IO.Class   (MonadIO (..))
import Dhall.Core               (URL (..), File (..), Directory (..))
import Lens.Family.State.Strict (zoom)

import qualified Data.Foldable
import qualified Data.Text.Encoding
import qualified Data.Text.IO
#endif

normalize' :: Expr Src Void -> Text
normalize' = Dhall.Core.pretty . Dhall.Core.normalize

normalizeWith' :: Normalizer Void -> Expr Src Void -> Text
normalizeWith' ctx t =
  Dhall.Core.pretty (Dhall.Core.normalizeWith (Just (ReifiedNormalizer ctx)) t)

code :: Text -> IO (Expr Src Void)
code = codeWith Dhall.Context.empty

codeWith :: Context (Expr Src Void) -> Text -> IO (Expr Src Void)
codeWith ctx expr = do
    expr0 <- case Dhall.Parser.exprFromText mempty expr of
        Left parseError -> Control.Exception.throwIO parseError
        Right expr0     -> return expr0
    expr1 <- load expr0
    case Dhall.TypeCheck.typeWith ctx expr1 of
        Left typeError -> Control.Exception.throwIO typeError
        Right _        -> return ()
    return expr1

load :: Expr Src Import -> IO (Expr Src Void)
load = loadRelativeTo "." UseSemanticCache

loadRelativeTo :: FilePath.FilePath -> SemanticCacheMode -> Expr Src Import -> IO (Expr Src Void)
loadRelativeTo rootDirectory semanticCacheMode expression =
    State.evalStateT
        (loadWith expression)
        (Dhall.Import.emptyStatus rootDirectory) { _semanticCacheMode = semanticCacheMode }

#if defined(WITH_HTTP) && defined(NETWORK_TESTS)
loadWith :: Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith = Dhall.Import.loadWith

#else
loadWith :: Expr Src Import -> StateT Status IO (Expr Src Void)
loadWith expr = do
    zoom Dhall.Import.remote (State.put mockRemote)
    Dhall.Import.loadWith expr

mockRemote :: Dhall.Core.URL -> StateT Status IO Data.Text.Text
mockRemote
    url@URL
        { authority = "raw.githubusercontent.com"
        , path = File (Directory components) file
        } = do
    let localDir = case reverse components of
            "dhall-lang" : "dhall-lang" : _ : rest ->
                reverse ("dhall-lang" : rest)
            "Nadrieril" : "dhall-rust" : _ : "dhall" : rest ->
                reverse ("dhall-lang" : rest)
            _ -> do
                fail ("Unable to mock URL: " <> Text.unpack (Dhall.Core.pretty url))

    localPath <- Dhall.Import.localToPath Dhall.Core.Here (File (Directory localDir) file)

    liftIO (Data.Text.IO.readFile localPath)

mockRemote
    URL { authority = "prelude.dhall-lang.org"
        , path = File (Directory components) file
        } = do
    let localDir = components ++ [ "Prelude", "dhall-lang" ]

    localPath <- Dhall.Import.localToPath Dhall.Core.Here (File (Directory localDir) file)

    liftIO (Data.Text.IO.readFile localPath)

mockRemote url@URL{ authority = "test.dhall-lang.org", path, headers } =
    case (path, fmap Dhall.Import.toHeaders headers) of
        (File (Directory []) "foo", Just [("test", _)]) ->
            return "./bar"
        (File (Directory []) "bar", Just [("test", _)]) ->
            return "True"
        (File (Directory ["cors"]) "AllowedAll.dhall", _) ->
            return "42"
        (File (Directory ["cors"]) "OnlyGithub.dhall", _) ->
            return "42"
        (File (Directory ["cors"]) "OnlySelf.dhall", _) ->
            return "42"
        (File (Directory ["cors"]) "OnlyOther.dhall", _) ->
            return "42"
        (File (Directory ["cors"]) "Empty.dhall", _) ->
            return "42"
        (File (Directory ["cors"]) "NoCORS.dhall", _) ->
            return "42"
        (File (Directory ["cors"]) "Null.dhall", _) ->
            return "42"
        (File (Directory ["cors"]) "SelfImportAbsolute.dhall", _) ->
            return "https://test.dhall-lang.org/cors/NoCORS.dhall"
        (File (Directory ["cors"]) "SelfImportRelative.dhall", _) ->
            return "./NoCORS.dhall"
        (File (Directory ["cors"]) "TwoHopsFail.dhall", _) ->
            return "https://raw.githubusercontent.com/dhall-lang/dhall-lang/5ff7ecd2411894dd9ce307dc23020987361d2d43/tests/import/data/cors/OnlySelf.dhall"
        (File (Directory ["cors"]) "TwoHopsSuccess.dhall", _) ->
            return "https://raw.githubusercontent.com/dhall-lang/dhall-lang/5ff7ecd2411894dd9ce307dc23020987361d2d43/tests/import/data/cors/OnlyGithub.dhall"
        _ -> do
            fail ("Unable to mock URL: " <> Text.unpack (Dhall.Core.pretty url))

mockRemote url@URL{ authority = "httpbin.org", path, headers } =
    case (path, fmap Dhall.Import.toHeaders headers) of
        (File (Directory []) "user-agent", Just [("user-agent", userAgent)]) -> do
            let agentText = Data.Text.Encoding.decodeUtf8 userAgent

            return ("{\n  \"user-agent\": \"" <> agentText <> "\"\n}\n")
        (File (Directory []) "user-agent", Nothing) -> do
            return ("{\n  \"user-agent\": \"Dhall\"\n}\n")
        _ -> do
            fail ("Unable to mock URL: " <> Text.unpack (Dhall.Core.pretty url))

mockRemote url = do
    let urlString = Text.unpack (Dhall.Core.pretty url)
    fail ("(mock http) Url does not match any of the hard-coded rules: "
        <> urlString)
#endif

{- Given a test prefix, returns a managed resource
   which sets / reverts relevant environment variables based
   on `prefix <> "ENV.dhall"` (if present)
 -}
managedTestEnvironment :: Text -> Turtle.Managed [(Text, Maybe Text)]
managedTestEnvironment prefix = Turtle.managed (Control.Exception.bracket setup cleanup)
  where
    envPath = Text.unpack (prefix <> "ENV.dhall")

    setup :: IO [(Text, Maybe Text)]
    setup = do
        envFileContents <-
            tryJust (guard . isDoesNotExistError) (Text.IO.readFile envPath)

        testEnv <- case envFileContents of
            Right contents -> do
                resolved <- code contents
                return (convertEnvExpr (Dhall.Core.normalize resolved))
            Left _ -> return []

        traverse setEnv testEnv

    cleanup :: [(Text, Maybe Text)] -> IO ()
    cleanup = Data.Foldable.traverse_ restoreEnv

    convertEnvExpr :: Expr Src Void -> [(Text, Text)]
    convertEnvExpr (ListLit _ hs) = Data.Foldable.toList (Data.Foldable.fold maybePairs)
      where
          maybePairs = mapM toPair hs

          toPair :: Expr s a -> Maybe (Text, Text)
          toPair (RecordLit m) = do
              (Dhall.Core.recordFieldValue -> TextLit (Chunks [] key), Dhall.Core.recordFieldValue -> TextLit (Chunks [] value))
                  <- lookupHeader <|> lookupMapKey
              return (key, value)
                where
                  lookupHeader = liftA2 (,) (Dhall.Map.lookup "header" m) (Dhall.Map.lookup "value" m)
                  lookupMapKey = liftA2 (,) (Dhall.Map.lookup "mapKey" m) (Dhall.Map.lookup "mapValue" m)
          toPair _ = Nothing
    convertEnvExpr _ = []

    setEnv :: (Text, Text) -> IO (Text, Maybe Text)
    setEnv (k, v) = do
        old <- Turtle.need k
        Turtle.export k v
        return (k, old)

    restoreEnv :: (Text, Maybe Text) -> IO ()
    restoreEnv (k, Just old) = Turtle.export k old
    restoreEnv (k, Nothing) = Turtle.unset k

equivalent :: Text -> Text -> IO ()
equivalent text0 text1 = do
    expr0 <- fmap Dhall.Core.normalize (code text0) :: IO (Expr Void Void)
    expr1 <- fmap Dhall.Core.normalize (code text1) :: IO (Expr Void Void)
    assertEqual "Expressions are not equivalent" expr0 expr1

assertNormalizesTo :: Expr Src Void -> Text -> IO ()
assertNormalizesTo e expected = do
  assertBool msg (not $ Dhall.Core.isNormalized e)
  normalize' e @?= expected
  where msg = "Given expression is already in normal form"

assertNormalizesToWith :: Normalizer Void -> Expr Src Void -> Text -> IO ()
assertNormalizesToWith ctx e expected = do
  assertBool msg (not $ Dhall.Core.isNormalizedWith ctx (first (const ()) e))
  normalizeWith' ctx e @?= expected
  where msg = "Given expression is already in normal form"

assertNormalized :: Expr Src Void -> IO ()
assertNormalized e = do
  assertBool msg1 (Dhall.Core.isNormalized e)
  assertEqual msg2 (normalize' e) (Dhall.Core.pretty e)
  where msg1 = "Expression was not in normal form"
        msg2 = "Normalization is not supposed to change the expression"

assertTypeChecks :: Text -> IO ()
assertTypeChecks text = Data.Functor.void (code text)

assertDoesntTypeCheck :: Text -> IO ()
assertDoesntTypeCheck text = do
    expr0 <- case Dhall.Parser.exprFromText mempty text of
        Left parseError -> Control.Exception.throwIO parseError
        Right e         -> return e
    expr1 <- load expr0
    case Dhall.TypeCheck.typeOf expr1 of
        Left _      -> return ()
        Right type_ -> fail ("Bad type for " <> Text.unpack text <> "\n  " <> show type_)

{-| Automatically run a test on all files in a directory tree that end in
    @A.dhall@
-}
discover :: Pattern Text -> (Text -> TestTree) -> Shell FilePath -> IO TestTree
discover pattern buildTest paths = do
    let shell = do
            path_ <- paths

            let pathText = Turtle.format fp path_

            prefix : _ <- return (Turtle.match pattern pathText)

            return (buildTest prefix)

    tests <- Turtle.fold shell Foldl.list

    return (Tasty.testGroup "discover" tests)

testCase :: Text -> [ FilePath ] -> Assertion -> TestTree
testCase prefix expectedFailures assertion =
    if prefix `elem` map (Turtle.format fp) expectedFailures
    then Tasty.ExpectedFailure.expectFail test
    else test
  where
    test = Test.Tasty.HUnit.testCase (Text.unpack prefix) assertion

{-| Path names on Windows are not valid Dhall paths due to using backslashes
    instead of forwardslashes to separate path components.  This utility fixes
    them if necessary
-}
toDhallPath :: Text -> Text
toDhallPath = Text.replace "\\" "/"