TestPretty.hs

{-# LANGUAGE OverloadedStrings #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Swarm unit tests
module TestPretty where

import Swarm.Language.Pretty
import Swarm.Language.Syntax hiding (mkOp)
import Swarm.Language.Types
import Test.Tasty
import Test.Tasty.HUnit

testPrettyConst :: TestTree
testPrettyConst =
  testGroup
    "Language - pretty"
    [ testCase
        "operators #8 - function application unchanged"
        ( equalPretty "f say" $
            TApp (TVar "f") (TConst Say)
        )
    , testCase
        "operators #8 - double function application unchanged"
        ( equalPretty "f () ()" $
            TApp (TApp (TVar "f") TUnit) TUnit
        )
    , testCase
        "operators #8 - embrace operator parameter"
        ( equalPretty "f (==)" $
            TApp (TVar "f") (TConst Eq)
        )
    , testCase
        "operators #8 - unary negation"
        ( equalPretty "-3" $
            TApp (TConst Neg) (TInt 3)
        )
    , testCase
        "operators #8 - double unary negation"
        ( equalPretty "-(-1)" $
            TApp (TConst Neg) $
              TApp (TConst Neg) (TInt 1)
        )
    , testCase
        "operators #8 - unary negation with strongly fixing binary operator"
        ( equalPretty "-1 ^ (-2)"
            . TApp (TConst Neg)
            . mkOp' Exp (TInt 1)
            $ TApp (TConst Neg) (TInt 2)
        )
    , testCase
        "operators #8 - unary negation with weakly fixing binary operator"
        ( equalPretty "-(1 + -2)"
            . TApp (TConst Neg)
            . mkOp' Add (TInt 1)
            $ TApp (TConst Neg) (TInt 2)
        )
    , testCase
        "operators #8 - simple infix operator"
        ( equalPretty "1 == 2" $
            mkOp' Eq (TInt 1) (TInt 2)
        )
    , testCase
        "operators #8 - infix operator with less fixing inner operator"
        ( equalPretty "1 * (2 + 3)" $
            mkOp' Mul (TInt 1) (mkOp' Add (TInt 2) (TInt 3))
        )
    , testCase
        "operators #8 - infix operator with more fixing inner operator"
        ( equalPretty "1 + 2 * 3" $
            mkOp' Add (TInt 1) (mkOp' Mul (TInt 2) (TInt 3))
        )
    , testCase
        "operators #8 - infix operator right associativity"
        ( equalPretty "2 ^ 4 ^ 8" $
            mkOp' Exp (TInt 2) (mkOp' Exp (TInt 4) (TInt 8))
        )
    , testCase
        "operators #8 - infix operator right associativity not applied to left"
        ( equalPretty "(2 ^ 4) ^ 8" $
            mkOp' Exp (mkOp' Exp (TInt 2) (TInt 4)) (TInt 8)
        )
    , testCase
        "pairs #225 - nested pairs are printed right-associative"
        ( equalPretty "(1, 2, 3)" $
            TPair (TInt 1) (TPair (TInt 2) (TInt 3))
        )
    , testCase
        "void type"
        ( assertEqual "" "void" . show $ ppr TyVoid
        )
    , testCase
        "type ascription"
        ( equalPretty "1 : int" $
            TAnnotate (TInt 1) (Forall [] TyInt)
        )
    , testCase
        "lambda precedence (#1468)"
        ( equalPretty "\\m. case m (\\x. x + 1) (\\y. y * 2)" $
            TLam
              "m"
              Nothing
              ( TConst Case
                  :$: STerm (TVar "m")
                  :$: STerm (TLam "x" Nothing (mkOp' Add (TVar "x") (TInt 1)))
                  :$: STerm (TLam "y" Nothing (mkOp' Mul (TVar "y") (TInt 2)))
              )
        )
    ]
 where
  equalPretty :: String -> Term -> Assertion
  equalPretty expected term = assertEqual "" expected . show $ ppr term