lens-5: tests/hunit.hs

{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Main (hunit)
-- Copyright   :  (C) 2012-14 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  portable
--
-- This module provides a simple hunit test suite for lens.
--
-- The code attempts to enumerate common use cases rather than give an example
-- of each available lens function. The tests here merely scratch the surface
-- of what is possible using the lens package; there are a great many use cases
-- (and lens functions) that aren't covered.
-----------------------------------------------------------------------------
module Main (main) where

import Control.Lens
import Control.Monad.State
import Data.Char
import qualified Data.List as List
import qualified Data.Map as Map
import Data.Map (Map)
#if !(MIN_VERSION_base(4,11,0))
import Data.Monoid
#endif
import Test.Framework.Providers.HUnit
import Test.Framework
import Test.HUnit hiding (test)


data Point =
  Point
  { _x :: Int -- ^ X coordinate
  , _y :: Int -- ^ Y coordinate
  } deriving (Show, Eq, Ord)

makeLenses ''Point

data Box =
  Box
  { _low :: Point  -- ^ The lowest used coordinates.
  , _high :: Point -- ^ The highest used coordinates.
  } deriving (Show, Eq)

makeLenses ''Box

data Polygon =
  Polygon
  { _points :: [ Point ]
  , _labels :: Map Point String
  , _box :: Box
  } deriving (Show, Eq)

makeLenses ''Polygon

data Shape = SBox Box | SPolygon Polygon | SCircle Point Int | SVoid
makePrisms ''Shape

origin =
  Point { _x = 0, _y = 0 }

vectorFrom fromPoint toPoint =
  Point
  { _x = toPoint^.x - fromPoint^.x
  , _y = toPoint^.y - fromPoint^.y
  }

trig =
  Polygon
  { _points = [ Point { _x = 0, _y = 0 }
              , Point { _x = 4, _y = 7 }
              , Point { _x = 8, _y = 0 } ]
  , _labels = Map.fromList [ (Point { _x = 0, _y = 0 }, "Origin")
                           , (Point { _x = 4, _y = 7 }, "Peak") ]
  , _box = Box { _low = Point { _x = 0, _y = 0 }
               , _high = Point { _x = 8, _y = 7 } }
  }

case_read_record_field =
  (trig^.box.high.y)
    @?= 7

case_read_state_record_field =
  runState test trig @?= (7, trig)
  where
    test = use $ box.high.y

case_read_record_field_and_apply_function =
  (trig^.points.to last.to (vectorFrom origin).x)
    @?= 8

case_read_state_record_field_and_apply_function =
  runState test trig @?= (8, trig)
  where test = use $ points.to last.to (vectorFrom origin).x

case_write_record_field =
  (trig & box.high.y .~ 6)
    @?= trig { _box = (trig & _box)
               { _high = (trig & _box & _high)
                         { _y = 6 } } }

case_write_state_record_field = do
  let trig' = trig { _box = (trig & _box)
                            { _high = (trig & _box & _high)
                                      { _y = 6 } } }
  runState test trig @?= ((), trig')
  where
    test = box.high.y .= 6

case_write_record_field_and_access_new_value =
  (trig & box.high.y <.~ 6)
    @?= (6, trig { _box = (trig & _box)
                          { _high = (trig & _box & _high)
                                    { _y = 6 } } })

case_write_state_record_field_and_access_new_value = do
  let trig' = trig { _box = (trig & _box)
                            { _high = (trig & _box & _high)
                                      { _y = 6 } } }
  runState test trig @?= (6, trig')
  where
    test = box.high.y <.= 6

case_write_record_field_and_access_old_value =
  (trig & box.high.y <<.~ 6)
    @?= (7, trig { _box = (trig & _box)
                          { _high = (trig & _box & _high)
                                    { _y = 6 } } })

case_write_state_record_field_and_access_old_value = do
  let trig' = trig { _box = (trig & _box)
                            { _high = (trig & _box & _high)
                                      { _y = 6 } } }
  runState test trig @?= (7, trig')
  where
    test = box.high.y <<.= 6

case_modify_record_field =
  (trig & box.low.y %~ (+ 2))
    @?= trig { _box = (trig & _box)
                      { _low = (trig & _box & _low)
                               { _y = ((trig & _box & _low & _y) + 2) } } }

case_modify_state_record_field = do
  let trig' = trig { _box = (trig & _box)
                            { _low = (trig & _box & _low)
                                     { _y = ((trig & _box & _low & _y) + 2) } } }
  runState test trig @?= ((), trig')
  where
    test = box.low.y %= (+ 2)

case_modify_record_field_and_access_new_value =
  (trig & box.low.y <%~ (+ 2))
    @?= (2, trig { _box = (trig & _box)
                          { _low = (trig & _box & _low)
                                   { _y = ((trig & _box & _low & _y) + 2) } } })

case_modify_state_record_field_and_access_new_value = do
  let trig' = trig { _box = (trig & _box)
                            { _low = (trig & _box & _low)
                                     { _y = ((trig & _box & _low & _y) + 2) } } }
  runState test trig @?= (2, trig')
  where
    test = box.low.y <%= (+ 2)

case_modify_record_field_and_access_old_value =
  (trig & box.low.y <<%~ (+ 2))
    @?= (0, trig { _box = (trig & _box)
                          { _low = (trig & _box & _low)
                                   { _y = ((trig & _box & _low & _y) + 2) } } })

case_modify_state_record_field_and_access_old_value = do
  let trig' = trig { _box = (trig & _box)
                            { _low = (trig & _box & _low)
                                     { _y = ((trig & _box & _low & _y) + 2) } } }
  runState test trig @?= (0, trig')
  where
    test = box.low.y <<%= (+ 2)

case_modify_record_field_and_access_side_result = do
  runState test trig @?= (8, trig')
  where
    test = box.high %%= modifyAndCompute
    modifyAndCompute point =
      (point ^. x, point & y +~ 2)
    trig' = trig { _box = (trig & _box)
                            { _high = (trig & _box & _high)
                                      { _y = ((trig & _box & _high & _y) + 2) } } }

case_increment_record_field =
  (trig & box.low.y +~ 1) -- And similarly for -~ *~ //~ ^~ ^^~ **~ ||~ &&~
    @?= trig { _box = (trig & _box)
                      { _low = (trig & _box & _low)
                               { _y = ((trig & _box & _low & _y) + 1) } } }

case_increment_state_record_field =
  runState test trig @?= ((), trig')
  where
    test = box.low.y += 1
    trig' = trig { _box = (trig & _box)
                   { _low = (trig & _box & _low)
                     { _y = ((trig & _box & _low & _y) + 1) } } }

case_append_to_record_field =
  (trig & points <>~ [ origin ])
    @?= trig { _points = (trig & _points) <> [ origin ] }

case_append_to_state_record_field = do
  runState test trig @?= ((), trig')
  where
    test = points <>= [ origin ]
    trig' = trig { _points = (trig & _points) <> [ origin ] }

case_append_to_record_field_and_access_new_value =
  (trig & points <<>~ [ origin ])
    @?= (_points trig <> [ origin ], trig { _points = (trig & _points) <> [ origin ] })

case_append_to_state_record_field_and_access_new_value = do
  runState test trig @?= (_points trig <> [ origin ], trig')
  where
    test = points <<>= [ origin ]
    trig' = trig { _points = (trig & _points) <> [ origin ] }

case_append_to_record_field_and_access_old_value =
  (trig & points <<%~ (<>[origin]))
    @?= (_points trig, trig { _points = (trig & _points) <> [ origin ] })

case_append_to_state_record_field_and_access_old_value = do
  runState test trig @?= (_points trig, trig')
  where
    test = points <<%= (<>[origin])
    trig' = trig { _points = (trig & _points) <> [ origin ] }

case_read_maybe_map_entry = trig^.labels.at origin @?= Just "Origin"

case_read_maybe_state_map_entry =
  runState test trig @?= (Just "Origin", trig)
  where test = use $ labels.at origin

case_read_map_entry = trig^.labels.ix origin @?= "Origin"

case_read_state_map_entry = runState test trig @?= ("Origin", trig)
  where test = use $ labels.ix origin

case_modify_map_entry =
  (trig & labels.ix origin %~ List.map toUpper)
    @?= trig { _labels = Map.fromList [ (Point { _x = 0, _y = 0 }, "ORIGIN")
                                      , (Point { _x = 4, _y = 7 }, "Peak") ] }

case_insert_maybe_map_entry =
  (trig & labels.at (Point { _x = 8, _y = 0 }) .~ Just "Right")
    @?= trig { _labels = Map.fromList [ (Point { _x = 0, _y = 0 }, "Origin")
                                      , (Point { _x = 4, _y = 7 }, "Peak")
                                      , (Point { _x = 8, _y = 0 }, "Right") ] }

case_delete_maybe_map_entry =
  (trig & labels.at origin .~ Nothing)
    @?= trig { _labels = Map.fromList [ (Point { _x = 4, _y = 7 }, "Peak") ] }

case_read_list_entry =
  (trig ^? points.element 0)
    @?= Just origin

case_write_list_entry =
  (trig & points.element 0 .~ Point { _x = 2, _y = 0 })
    @?= trig { _points = [ Point { _x = 2, _y = 0 }
                         , Point { _x = 4, _y = 7 }
                         , Point { _x = 8, _y = 0 } ] }

case_write_through_list_entry =
  (trig & points.element 0 . x .~ 2)
    @?= trig { _points = [ Point { _x = 2, _y = 0 }
                         , Point { _x = 4, _y = 7 }
                         , Point { _x = 8, _y = 0 } ] }

main :: IO ()
main = defaultMain
  [ testGroup "Main"
    [ testCase "read record field" case_read_record_field
    , testCase "read state record field" case_read_state_record_field
    , testCase "read record field and apply function" case_read_record_field_and_apply_function
    , testCase "read state record field and apply function" case_read_state_record_field_and_apply_function
    , testCase "write record field" case_write_record_field
    , testCase "write state record field" case_write_state_record_field
    , testCase "write record field and access new value" case_write_record_field_and_access_new_value
    , testCase "write state record field and access new value" case_write_state_record_field_and_access_new_value
    , testCase "write record field and access old value" case_write_record_field_and_access_old_value
    , testCase "write state record field and access old value" case_write_state_record_field_and_access_old_value
    , testCase "modify record field" case_modify_record_field
    , testCase "modify state record field" case_modify_state_record_field
    , testCase "modify record field and access new value" case_modify_record_field_and_access_new_value
    , testCase "modify state record field and access new value" case_modify_state_record_field_and_access_new_value
    , testCase "modify record field and access old value" case_modify_record_field_and_access_old_value
    , testCase "modify state record field and access old value" case_modify_state_record_field_and_access_old_value
    , testCase "modify record field and access side result" case_modify_record_field_and_access_side_result
    , testCase "increment record field" case_increment_record_field
    , testCase "increment state record field" case_increment_state_record_field
    , testCase "append to record field" case_append_to_record_field
    , testCase "append to state record field" case_append_to_state_record_field
    , testCase "append to record field and access new value" case_append_to_record_field_and_access_new_value
    , testCase "append to state record field and access new value" case_append_to_state_record_field_and_access_new_value
    , testCase "append to record field and access old value" case_append_to_record_field_and_access_old_value
    , testCase "append to state record field and access old value" case_append_to_state_record_field_and_access_old_value
    , testCase "read maybe map entry" case_read_maybe_map_entry
    , testCase "read maybe state map entry" case_read_maybe_state_map_entry
    , testCase "read map entry" case_read_map_entry
    , testCase "read state map entry" case_read_state_map_entry
    , testCase "modify map entry" case_modify_map_entry
    , testCase "insert maybe map entry" case_insert_maybe_map_entry
    , testCase "delete maybe map entry" case_delete_maybe_map_entry
    , testCase "read list entry" case_read_list_entry
    , testCase "write list entry" case_write_list_entry
    , testCase "write through list entry" case_write_through_list_entry
    ]
  ]