content: {-# LANGUAGE OverloadedStrings #-}
  
  -- |
  -- SPDX-License-Identifier: BSD-3-Clause
  --
  -- Swarm unit tests
  module TestPretty where
  
  import Data.Fix (Fix (..))
  import Swarm.Language.Syntax hiding (mkOp)
  import Swarm.Language.Types
  import Swarm.Pretty
  import Test.Tasty
  import Test.Tasty.HUnit
  import Witch (into)
  
  testPrettyConst :: TestTree
  testPrettyConst =
    testGroup
      "Language - pretty"
      [ testCase
          "operators #8 - function application unchanged"
          ( equalPrettyLine "f say" $
              TApp (TVar "f") (TConst Say)
          )
      , testCase
          "operators #8 - double function application unchanged"
          ( equalPrettyLine "f () ()" $
              TApp (TApp (TVar "f") TUnit) TUnit
          )
      , testCase
          "operators #8 - embrace operator parameter"
          ( equalPrettyLine "f (==)" $
              TApp (TVar "f") (TConst Eq)
          )
      , testCase
          "operators #8 - unary negation"
          ( equalPrettyLine "-3" $
              TApp (TConst Neg) (TInt 3)
          )
      , testCase
          "operators #8 - double unary negation"
          ( equalPrettyLine "-(-1)" $
              TApp (TConst Neg) $
                TApp (TConst Neg) (TInt 1)
          )
      , testCase
          "operators #8 - unary negation with strongly fixing binary operator"
          ( equalPrettyLine "-1 ^ (-2)"
              . TApp (TConst Neg)
              . mkOp' Exp (TInt 1)
              $ TApp (TConst Neg) (TInt 2)
          )
      , testCase
          "operators #8 - unary negation with weakly fixing binary operator"
          ( equalPrettyLine "-(1 + -2)"
              . TApp (TConst Neg)
              . mkOp' Add (TInt 1)
              $ TApp (TConst Neg) (TInt 2)
          )
      , testCase
          "operators #8 - simple infix operator"
          ( equalPrettyLine "1 == 2" $
              mkOp' Eq (TInt 1) (TInt 2)
          )
      , testCase
          "operators #8 - infix operator with less fixing inner operator"
          ( equalPrettyLine "1 * (2 + 3)" $
              mkOp' Mul (TInt 1) (mkOp' Add (TInt 2) (TInt 3))
          )
      , testCase
          "operators #8 - infix operator with more fixing inner operator"
          ( equalPrettyLine "1 + 2 * 3" $
              mkOp' Add (TInt 1) (mkOp' Mul (TInt 2) (TInt 3))
          )
      , testCase
          "operators #8 - infix operator right associativity"
          ( equalPrettyLine "2 ^ 4 ^ 8" $
              mkOp' Exp (TInt 2) (mkOp' Exp (TInt 4) (TInt 8))
          )
      , testCase
          "operators #8 - infix operator right associativity not applied to left"
          ( equalPrettyLine "(2 ^ 4) ^ 8" $
              mkOp' Exp (mkOp' Exp (TInt 2) (TInt 4)) (TInt 8)
          )
      , testCase
          "pairs #225 - nested pairs are printed right-associative"
          ( equalPrettyLine "(1, 2, 3)" $
              TPair (TInt 1) (TPair (TInt 2) (TInt 3))
          )
      , testCase
          "type ascription"
          ( equalPrettyLine "1 : Int" $
              TAnnotate (TInt 1) (mkTrivPoly TyInt)
          )
      , testCase
          "lambda precedence (#1468)"
          ( equalPrettyLine "\\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)))
                )
          )
      , testGroup
          "types"
          [ testCase
              "Void type"
              (equalPrettyLine "Void" TyVoid)
          , testCase
              "Unit type"
              (equalPrettyLine "Unit" TyUnit)
          , testCase
              "Function type"
              (equalPrettyLine "Int -> Cmd Unit" $ TyInt :->: TyCmd TyUnit)
          , testCase
              "Cmd type"
              (equalPrettyLine "Cmd (Int -> Int)" $ TyCmd (TyInt :->: TyInt))
          , testCase
              "Product type"
              (equalPrettyLine "Int * Int" $ TyInt :*: TyInt)
          , testCase
              "Sum type"
              (equalPrettyLine "Int + Int" $ TyInt :+: TyInt)
          , testCase
              "Sum of sum right"
              (equalPrettyLine "Int + (Unit + Bool)" $ TyInt :+: (TyUnit :+: TyBool))
          , testCase
              "Sum of sum left"
              (equalPrettyLine "(Int + Unit) + Bool" $ (TyInt :+: TyUnit) :+: TyBool)
          , testCase
              "Product of product right"
              (equalPrettyLine "Int * (Unit * Bool)" $ TyInt :*: (TyUnit :*: TyBool))
          , testCase
              "Product of product left"
              (equalPrettyLine "(Int * Unit) * Bool" $ (TyInt :*: TyUnit) :*: TyBool)
          , testCase
              "Product of sum"
              (equalPrettyLine "Int * (Unit + Bool)" $ TyInt :*: (TyUnit :+: TyBool))
          , testCase
              "Sum of product"
              (equalPrettyLine "Int + (Unit * Bool)" $ TyInt :+: (TyUnit :*: TyBool))
          , testCase
              "Product of function"
              (equalPrettyLine "Int * (Unit -> Bool)" $ TyInt :*: (TyUnit :->: TyBool))
          , testCase
              "Function of product"
              (equalPrettyLine "Int -> (Unit * Bool)" $ TyInt :->: (TyUnit :*: TyBool))
          , testCase
              "Function of function right"
              (equalPrettyLine "Int -> Unit -> Bool" $ TyInt :->: (TyUnit :->: TyBool))
          , testCase
              "Function of function left"
              (equalPrettyLine "(Int -> Unit) -> Bool" $ (TyInt :->: TyUnit) :->: TyBool)
          , testCase
              "density (two nested products)"
              ( equalPrettyLine "((Int * Int) * (Int * Int)) -> Cmd Int" $
                  ((TyInt :*: TyInt) :*: (TyInt :*: TyInt)) :->: TyCmd TyInt
              )
          ]
      , testGroup
          "types but with limited width for pretty printing"
          [ testCase
              "Void type"
              (equalPrettyWidth 10 "Void" TyVoid)
          , testCase
              "Function type"
              (equalPrettyWidth 20 "Int -> Cmd Unit" $ TyInt :->: TyCmd TyUnit)
          , testCase
              "Cmd type"
              (equalPrettyWidth 20 "Cmd (Int -> Int)" $ TyCmd (TyInt :->: TyInt))
          , testCase
              "Product type"
              (equalPrettyWidth 20 "Int * Int" $ TyInt :*: TyInt)
          , testCase
              "Function of function right"
              (equalPrettyWidth 10 "Int ->\nUnit ->\nBool" $ TyInt :->: (TyUnit :->: TyBool))
          , testCase
              "Function of function left"
              (equalPrettyWidth 20 "(Int -> Unit) ->\nBool" $ (TyInt :->: TyUnit) :->: TyBool)
          , testCase
              "density (two nested products) with  nested indentation"
              ( equalPrettyWidth 20 "(\n  (Int * Int) * (\n    Int * Int\n  )\n) -> Cmd Int" $
                  ((TyInt :*: TyInt) :*: (TyInt :*: TyInt)) :->: TyCmd TyInt
              )
          , testCase
              "Resonate"
              ( equalPrettyWidth 40 "Text -> ((Int * Int) * (Int * Int)) ->\nCmd (Unit + (Int * Int))" $
                  TyText :->: ((TyInt :*: TyInt) :*: (TyInt :*: TyInt)) :->: TyCmd (TyUnit :+: (TyInt :*: TyInt))
              )
          ]
      , testGroup
          "tydef"
          [ testCase "tydef alias" $
              equalPrettyLine "tydef X = Int end" $
                TTydef "X" (mkTrivPoly TyInt) Nothing (TConst Noop)
          , testCase "tydef Maybe" $
              equalPrettyLine "tydef Maybe a = Unit + a end" $
                TTydef "Maybe" (mkQPoly (TyUnit :+: TyVar "a")) Nothing (TConst Noop)
          , testCase "tydef multi-arg" $
              equalPrettyLine "tydef Foo a b c d = Unit + ((a * b) + ((c -> d) * a)) end" $
                TTydef
                  "Foo"
                  ( mkQPoly
                      (TyUnit :+: (TyVar "a" :*: TyVar "b") :+: ((TyVar "c" :->: TyVar "d") :*: TyVar "a"))
                  )
                  Nothing
                  (TConst Noop)
          , testCase "consecutive tydef" $
              equalPrettyLine "tydef X = Int end\n\ntydef Y = Bool end" $
                TTydef "X" (mkTrivPoly TyInt) Nothing (TTydef "Y" (mkTrivPoly TyBool) Nothing (TConst Noop))
          ]
      , testGroup
          "recursive types"
          [ testCase "nat" $
              equalPrettyLine "rec n. Unit + n" $
                TyRec "n" (TyUnit :+: Fix (TyRecVarF NZ))
          , testCase "list" $
              equalPrettyLine "rec list. Unit + (a * list)" $
                TyRec "list" (TyUnit :+: (TyVar "a" :*: Fix (TyRecVarF NZ)))
          , testCase "rose" $
              equalPrettyLine "rec r. a * (rec l. Unit + (r * l))" $
                TyRec "r" (TyVar "a" :*: TyRec "l" (TyUnit :+: (Fix (TyRecVarF (NS NZ)) :*: Fix (TyRecVarF NZ))))
          ]
      ]
   where
    equalPrettyLine :: PrettyPrec a => String -> a -> Assertion
    equalPrettyLine expected = assertEqual "" expected . into @String . prettyTextLine
  
    equalPrettyWidth :: PrettyPrec a => Int -> String -> a -> Assertion
    equalPrettyWidth width expected doc = assertEqual "" expected . into @String $ prettyTextWidth doc width
  