HList-0.4.0.0: examples/lens.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds #-}
{- | Demonstrates @hLens@. See also labelable.hs which is more "convenient"

-}
module Main where
import Data.HList.CommonMain
import Control.Lens

makeLabels6 (words "x y z")


#if __GLASGOW_HASKELL__ > 707
yRec = y .=. 321 .*. x .=. 123 .*. emptyRecord
#else
-- defaulting doesn't work in ghc-7.6.3
yRec = y .=. (321 :: Integer) .*. x .=. (123 :: Integer) .*. emptyRecord
#endif

r = x .=. "hi" .*.
    y .=. yRec .*.
    emptyRecord


_ = (r^.y') `asTypeOf` hRearrange'
    (x .=. 1 .*. y .=. 1 .*. emptyRecord)

rSmall = x .=. "" .*. emptyRecord

x' a = hLens x a
y' a = hLens y a

main = do
    print (view (hLens x) r)
    print (set (hLens x) () r)

    print (r ^. hLens y . hLens x)
    print (r & hLens y . hLens y .~ "xy")


    putStrLn "\n\nand repeat:"

    -- and now for with hLens applied second
    print (view x' r)
    print (set x' () r)

    print (r ^. y' . y')
    print (r & y' . y' .~ "xy")

    putStrLn "\n\nIsos"
    print (r & sameLength . unlabeled . hTuple . _1 .~ ())
    print (r & sameLength . unlabeled . hTuple . _2 .~ ())
    print (z .=. () .*. r
              & unlabeled' . from tipHList %~ ttip (\x z -> x ++ show (z :: ())))

    r ^. unlabeled . from tipHList & tipPutStrLn


tipPutStrLn tip = ttipM ?? tip $ \x -> do
  putStrLn x
  return x