TextFieldSpec.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Cursor.TextFieldSpec
  ( spec
  ) where

import Test.Hspec

import Test.QuickCheck
import Test.Validity

-- import Test.Validity.Optics
import Text.Show.Pretty (ppShow)

import qualified Data.Text as T

import qualified Data.List.NonEmpty as NE

import Control.Monad

import Cursor.List.NonEmpty
import Cursor.TextField
import Cursor.TextField.Gen ()
import Cursor.Types

spec :: Spec
spec = do
  eqSpecOnValid @TextFieldCursor
  genValidSpec @TextFieldCursor
  describe "Validity TextFieldCursor" $ do
    it "consider a textfield with a newline in the previous lines invalid" $
      forAllValid $ \tc ->
        shouldBeInvalid $
        TextFieldCursor
          { textFieldCursorNonEmpty =
              NonEmptyCursor
                {nonEmptyCursorPrev = ["\n"], nonEmptyCursorCurrent = tc, nonEmptyCursorNext = []}
          }
    it "consider a textfield with a newline in the next lines invalid" $
      forAllValid $ \tc ->
        shouldBeInvalid $
        TextFieldCursor
          { textFieldCursorNonEmpty =
              NonEmptyCursor
                {nonEmptyCursorPrev = [], nonEmptyCursorCurrent = tc, nonEmptyCursorNext = ["\n"]}
          }
  describe "makeTextFieldCursor" $ do
    it "produces a valid cursor for \"\\n\"" $ shouldBeValid $ makeTextFieldCursor "\n"
    it "produces a valid cursor for \"\\n\\n\"" $ shouldBeValid $ makeTextFieldCursor "\n\n"
    it "produces valid cursors" $ producesValidsOnValids makeTextFieldCursor
  describe "makeTextFieldCursorWithSelection" $ do
    it "produces a valid cursor for \"\\n\"" $
      forAllValid $ \x ->
        forAllValid $ \y -> shouldBeValid $ makeTextFieldCursorWithSelection x y "\n"
    it "produces a valid cursor for \"\\n\\n\"" $
      forAllValid $ \x ->
        forAllValid $ \y -> shouldBeValid $ makeTextFieldCursorWithSelection x y "\n\n"
    it "produces valid cursors" $ producesValidsOnValids3 makeTextFieldCursorWithSelection
    it "is the inverse of rebuildTextFieldCursor when using the current selection" $
      forAllValid $ \tfc -> do
        let (x, y) = textFieldCursorSelection tfc
            t = rebuildTextFieldCursor tfc
        case makeTextFieldCursorWithSelection x y t of
          Nothing -> expectationFailure "makeTextFieldCursorWithSelection should not have failed."
          Just tfc' ->
            unless (tfc' == tfc) $
            expectationFailure $
            unlines
              [ "expected"
              , ppShow tfc
              , "actual"
              , ppShow tfc'
              , "The selection of the original (expected) cursor was:"
              , show (x, y)
              , "The rebuild text was:"
              , show t
              ]
  describe "rebuildTextFieldCursorLines" $ do
    it "produces valid lists" $ producesValidsOnValids rebuildTextFieldCursorLines
    it "produces texts without newlines" $
      forAllValid $ \tfc -> do
        let ls = NE.toList $ rebuildTextFieldCursorLines tfc
        unless (all (T.all (/= '\n')) ls) $
          expectationFailure $
          unlines $ "Some of the following lines contain a newline:" : map show ls
  describe "rebuildTextFieldCursor" $ do
    it "produces valid texts" $ producesValidsOnValids rebuildTextFieldCursor
    it "is the inverse of makeTextFieldCursor" $
      inverseFunctionsOnValid makeTextFieldCursor rebuildTextFieldCursor
    it "is the inverse of makeTextFieldCursorWithSelection for integers, for any index" $
      forAllValid $ \x ->
        forAllValid $ \y ->
          inverseFunctionsIfFirstSucceedsOnValid
            (makeTextFieldCursorWithSelection x y)
            rebuildTextFieldCursor
  describe "textFieldCursorSelection" $
    it "produces valid tuples" $ producesValidsOnValids textFieldCursorSelection
  describe "emptyTextFieldCursor" $ it "is valid" $ shouldBeValid emptyTextFieldCursor
  describe "nullTextFieldCursor" $ it "produces valid" $ producesValidsOnValids nullTextFieldCursor
  describe "textFieldCursorSelectPrevLine" $ do
    it "produces valid cursors" $ producesValidsOnValids textFieldCursorSelectPrevLine
    it "is a movement" $ isMovementM textFieldCursorSelectPrevLine
    it "selects the previous line" pending
  describe "textFieldCursorSelectNextLine" $ do
    it "produces valid cursors" $ producesValidsOnValids textFieldCursorSelectNextLine
    it "is a movement" $ isMovementM textFieldCursorSelectNextLine
    it "selects the next line" pending
  describe "textFieldCursorSelectFirstLine" $ do
    it "produces valid cursors" $ producesValidsOnValids textFieldCursorSelectFirstLine
    it "is a movement" $ isMovement textFieldCursorSelectFirstLine
    it "is idempotent" $ idempotentOnValid textFieldCursorSelectFirstLine
    it "selects the first line" pending
  describe "textFieldCursorSelectLastLine" $ do
    it "produces valid cursors" $ producesValidsOnValids textFieldCursorSelectLastLine
    it "is a movement" $ isMovement textFieldCursorSelectLastLine
    it "is idempotent" $ idempotentOnValid textFieldCursorSelectLastLine
    it "selects the last line" pending
  describe "textFieldCursorSelectPrevChar" $ do
    it "produces valid cursors" $ producesValidsOnValids textFieldCursorSelectPrevChar
    it "selects the previous character on the current line" pending
  describe "textFieldCursorSelectNextChar" $ do
    it "produces valid cursors" $ producesValidsOnValids textFieldCursorSelectNextChar
    it "selects the previous character on the current line" pending
  describe "textFieldCursorIndexOnLine" $ do
    it "produces valid indices" $ producesValidsOnValids textFieldCursorIndexOnLine
    it "returns the index on the current line" pending
  describe "textFieldCursorSelectIndexOnLine" $ do
    it "produces valid cursors for any index" $
      producesValidsOnValids2 textFieldCursorSelectIndexOnLine
    it "selects the given index on the current line" pending
  describe "textFieldCursorInsertChar" $ do
    it "produces valid cursors" $
      forAllValid $ \d -> producesValidsOnValids (textFieldCursorInsertChar d)
    it "inserts a character before the cursor on the current line" pending
  describe "textFieldCursorAppendChar" $ do
    it "produces valid cursors" $
      forAllValid $ \d -> producesValidsOnValids (textFieldCursorAppendChar d)
    it "inserts a character after the cursor on the currrent line" pending
  describe "textFieldCursorInsertNewline" $ do
    it "produces valid cursors" $ producesValidsOnValids textFieldCursorInsertNewline
    it "inserts a new line" pending
  describe "textFieldCursorAppendNewline" $ do
    it "produces valid cursors" $ producesValidsOnValids textFieldCursorAppendNewline
  describe "textFieldCursorRemove" $ do
    it "produces valid cursors" $ producesValidsOnValids textFieldCursorRemove
    it "removes empty text field cursor" $
      textFieldCursorRemove emptyTextFieldCursor `shouldBe` Just Deleted
    it "removes a character or a line" pending
  describe "textFieldCursorDelete" $ do
    it "produces valid cursors" $ producesValidsOnValids textFieldCursorDelete
    it "removes empty text field cursor" $
      textFieldCursorDelete emptyTextFieldCursor `shouldBe` Just Deleted
    it "deletes a character or a line" pending
  describe "textFieldCursorSelectStartOfLine" $ do
    it "produces valid cursors" $ producesValidsOnValids textFieldCursorSelectStartOfLine
    it "selects the start of the current line" pending
  describe "textFieldCursorSelectEndOfLine" $ do
    it "produces valid cursors" $ producesValidsOnValids textFieldCursorSelectEndOfLine
    it "selects the end of the current line" pending

isMovementM :: (TextFieldCursor -> Maybe TextFieldCursor) -> Property
isMovementM func =
  forAllValid $ \tfc ->
    case func tfc of
      Nothing -> pure () -- Fine
      Just tfc' ->
        let tf = rebuildTextFieldCursor tfc
            tf' = rebuildTextFieldCursor tfc'
         in unless (tf == tf') $
            expectationFailure $
            unlines
              [ "Cursor before:\n" ++ show tfc
              , "TextField before:  \n" ++ show tf
              , "Cursor after: \n" ++ show tfc'
              , "TextField after:   \n" ++ show tf'
              ]

isMovement :: (TextFieldCursor -> TextFieldCursor) -> Property
isMovement func =
  forAllValid $ \tfc -> rebuildTextFieldCursor tfc `shouldBe` rebuildTextFieldCursor (func tfc)