references-0.3.0.1: Control/Reference/Examples/Examples.hs
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE LambdaCase, TypeOperators, BangPatterns #-}
{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes #-}
-- | A collection of random example references
module Control.Reference.Examples.Examples where
import Control.Reference
import System.Exit
import System.Timeout
import Test.HUnit
import Control.Instances.Morph
import Control.Monad.Trans.Maybe
import qualified Control.Lens as Lens
import Control.Concurrent
import Control.Monad.Identity
import Control.Monad.Trans.List
import Control.Applicative
import Control.Monad.Writer
import Data.Maybe
import qualified Data.Array as Arr
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import qualified Data.Sequence as Seq
import qualified Data.Tree as T
import Data.List as Ls
data A = A deriving (Eq, Show)
testAtArg :: Int -> Int
testAtArg = (atArg 3 .= 0) (+1)
test1 :: Maybe Int
test1 = just .= 3 $ Nothing
test2 :: Either A Int
test2 = right .= 3 $ Right 2
test3 :: Either A Int
test3 = right .- (+1) $ Right 2
test4 :: Either A (Maybe Int)
test4 = right&just .- (+1) $ Right (Just 2)
test5 :: Either A (Maybe [Int])
test5 = right&just&(element 3) .- (+1) $ Right (Just [1..10])
test6 :: (Int, Int)
test6 = both .- (+1) $ (0, 1)
test7 :: (Maybe Int, Maybe Int)
test7 = both&just .- (+1) $ (Just 0, Nothing)
-- should not block
test8 :: IO (MVar Int)
test8 = newEmptyMVar >>= emptyRef&mvar !- (+1)
isoList :: Simple Iso [()] Int
isoList = iso length (`replicate` ())
test9 :: [()]
test9 = isoList .- (+1)
$ 3 ^. turn isoList
test10 :: [Int]
test10 = [1..10] ^? _tail&traversal &+& _tail&_tail&traversal
test11 :: [Int]
test11 = _tail&traversal &+& _tail&_tail&traversal .- (+1) $ replicate 10 1
test12 :: Writer [String] (Int,Int)
test12 = (both :: Simple (WriterTraversal [String] Identity) (Int,Int) Int)
!| (tell . (:[]) . show) $ (0, 1)
data Dept = Dept { _manager :: Employee
, _staff :: [Employee]
} deriving (Eq, Show)
data Employee = Employee { __name :: String
, __salary :: Float
} deriving (Eq, Show)
$(Lens.makeLenses ''Employee)
manager :: Lens Dept Dept Employee Employee
manager = lens _manager (\b a -> a { _manager = b })
staff :: Lens Dept Dept [Employee] [Employee]
staff = lens _staff (\b a -> a { _staff = b })
name :: Lens Employee Employee String String
name = fromLens _name
salary :: Lens Employee Employee Float Float
salary = fromLens _salary
dept = Dept (Employee "Agamemnon" 100000) [Employee "Akhilles" 30000, Employee "Menelaos" 40000]
test13 :: Writer (Sum Float) Dept
test13 = let salaryOfEmployees :: Simple (WriterTraversal (Sum Float) Identity) Dept Float
salaryOfEmployees = (staff&traversal &+& manager)&salary
in salaryOfEmployees !| tell . Sum
$ manager&name .- ("Mr. "++)
$ dept
test14 :: [String]
test14 = traversal .- (`replicate` 'x') $ [1..10]
test15 :: (String, Char)
test15 = let lens_1 = fromLens Lens._1
in lens_1 .- show $ (2,'a')
test16 :: (Either Int Int, Either Int Int)
test16 = (_1 &+& _2) & (left &+& right) .- (+1)
$ both & anyway .- subtract 1
$ (Left 3, Right 1)
data PWrapped m a = PWrapped { _pwrap :: m a } deriving (Eq, Show)
$(makeReferences ''PWrapped)
test17 :: PWrapped Maybe String
test17 = pwrap .- (return . show . runIdentity) $ (PWrapped (Identity (3 :: Int)))
data MWrapped a = MWrapped { _mwrap :: Maybe a } deriving (Eq, Show)
$(makeReferences ''MWrapped)
test18 :: MWrapped String
test18 = mwrap .- (fmap show) $ MWrapped (Just (3 :: Int))
data Maybe' a = Just' { _fromJust' :: a }
| Nothing'
deriving (Eq, Show)
$(makeReferences ''Maybe')
test19 :: Maybe' String
test19 = fromJust' .- show $ Just' (42 :: Int)
data Tuple a b = Tuple { _fst' :: a, _snd' :: b } deriving (Eq, Show)
$(makeReferences ''Tuple)
test20 :: Tuple Int String
test20 = fst' .- length
$ snd' .- show
$ Tuple "almafa" 42
test21 :: IM.IntMap String
test21 = element 2 .= "two"
$ element 3 .- (++"_")
$ at 4 .= Just "4"
$ IM.fromList [(5, "5"), (2, "2")]
test22 :: Seq.Seq String
test22 = element 1 .- ("_"++)
$ element 3 .= "_"
$ Seq.fromList ["1","2","3"]
test23 :: Set.Set Int
test23 = contains 2 .= False
$ contains 3 .- not
$ contains 4 .- not
$ Set.fromList [1,2,3]
test24 :: IS.IntSet
test24 = contains 2 .= False
$ contains 3 .- not
$ contains 4 .- not
$ IS.fromList [1,2,3]
test25 :: T.Tree Int
test25 = (\tree -> element [1,0] .= fromJust (tree ^? element []) $ tree)
$ element [1] .- (+1)
$ element [2] .= 0
$ T.Node 1 [T.Node 2 [], T.Node 3 [T.Node 4 []]]
test26 :: Arr.Array Int String
test26 = element 1 .- (++"!")
$ element 2 .= "World"
$ Arr.listArray (1,3) ["Hello","My","World"]
test27 :: Map.Map String Int
test27 = at "2" .= Nothing
$ at "3" .- (fmap (subtract 1))
$ Map.fromList [("5",5), ("3",3), ("2",2)]
test28 :: Int -> Maybe String
test28 = at 3 .= Nothing
$ element 1 .- (++"_")
$ \a -> if a > 0 then Just (show a) else Nothing
-- test29 :: (Maybe Int, Either Int String)
-- test29 = let r = just &|& right
-- in r .- (\(a,b) -> (b,a)) $ (Just 3, Left 4)
data SameName a = Opt1 { _sameFld :: a }
| Opt2 { _sameFld :: a }
makeReferences ''SameName
sameFld' :: Simple Lens (SameName a) a
sameFld' = sameFld
data SameType a = SameType { sameType :: a, sameType2 :: a }
makeReferences ''SameType
data HigherEither x y a
= HigherLeft { _higherLeft :: x a }
| HigherRight { _higherRight :: y a }
makeReferences ''HigherEither
example1 :: IO String
example1 =
do result <- newEmptyMVar
updates <- replicateM 3 newEmptyMVar
hello <- newMVar (Just "World")
forkIO $ do mvar&just&_tail&_tail !- ('_':) $ hello
mvar != () $ (updates !! 0)
return ()
forkIO $ do mvar&just&(element 1) != 'u' $ hello
mvar != () $ (updates !! 1)
return ()
forkIO $ do mvar&just !- ("Hello " ++) $ hello
mvar != () $ (updates !! 2)
return ()
-- wait for all updates to happen
runListT $ (updates :: [MVar ()]) ^? traversal&mvar
Just x <- runMaybeT $ hello ^? (mvar & just)
mvar != x $ result
result ^? mvar
tests = TestList [
TestCase $ assertEqual "atArg" [2,3,0,5,6] (map testAtArg [1..5])
, TestCase $ assertEqual "test1" Nothing test1
, TestCase $ assertEqual "test2" (Right 3) test2
, TestCase $ assertEqual "test3" (Right 3) test3
, TestCase $ assertEqual "test4" (Right (Just 3)) test4
, TestCase $ assertEqual "test5" (Right (Just [1,2,3,5,5,6,7,8,9,10])) test5
, TestCase $ assertEqual "test6" (1,2) test6
, TestCase $ assertEqual "test7" (Just 1,Nothing) test7
, TestCase $ assertBool "test8" =<< ((==) <$> (newEmptyMVar >>= tryTakeMVar)
<*> (test8 >>= tryTakeMVar))
, TestCase $ assertEqual "test9" [(),(),(),()] test9
, TestCase $ assertEqual "test10" ([2..10]++[3..10]) test10
, TestCase $ assertEqual "test11" ([1,2]++replicate 8 3) test11
, TestCase $ assertEqual "test12" ["0","1"] (execWriter test12)
, TestCase $ assertEqual "test13" (dept { _manager = Employee "Mr. Agamemnon" 100000 }, Sum 170000)
(runWriter test13)
, TestCase $ assertEqual "test14" [replicate i 'x' | i <- [1..10]] test14
, TestCase $ assertEqual "test15" ("2",'a') test15
, TestCase $ assertEqual "test16" (Left 3, Right 1) test16
, TestCase $ assertEqual "test17" (PWrapped (Just "3")) test17
, TestCase $ assertEqual "test18" (MWrapped (Just "3")) test18
, TestCase $ assertEqual "test19" (Just' "42") test19
, TestCase $ assertEqual "test20" (Tuple 6 "42") test20
, TestCase $ assertEqual "test21" (IM.fromList [(2,"two"),(4,"4"),(5,"5")]) test21
, TestCase $ assertEqual "test22" (Seq.fromList ["1","_2","3"]) test22
, TestCase $ assertEqual "test23" (Set.fromList [1,4]) test23
, TestCase $ assertEqual "test24" (IS.fromList [1,4]) test24
, TestCase $ assertEqual "test25" (T.Node 1 [T.Node 2 [], T.Node 4 [T.Node 1 []]]) test25
, TestCase $ assertEqual "test26" (Arr.listArray (1,3) ["Hello!","World","World"]) test26
, TestCase $ assertEqual "test27" (Map.fromList [("5",5), ("3",2)]) test27
, TestCase $ assertEqual "test28" ["1_", "2"] (catMaybes $ map test28 [0..3])
, TestCase $ do ex1 <- timeout 10000000 example1
b <- case ex1 of Just x -> return $ ("_uH" Ls.\\ x) == ""
Nothing -> putStrLn "example1 is not evaluated on time" >> return False
assertBool "example1" b
]