{-# 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 -- 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 ] ]