git.fiddlerwoaroof.com
Raw Blame History
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DataKinds #-}

module Main where

import GHC.Generics
import Control.Lens
import Data.Generics.Product

data Person = Person { name :: String, age :: Int, eye_color :: String }
  deriving (Show, Generic)

data Person' = Person' { name' :: String, age' :: String, eye_color' :: String }
  deriving (Show, Generic, Eq)

ageT :: Functor f => (Int -> f String) -> Person -> f Person'
ageT f (Person name p_age eye_color) = fmap (\v -> Person' name v eye_color) (f p_age)

printAndReturn :: String -> IO String
printAndReturn v = do
  putStrLn v
  pure v

intoIdentity :: String -> Identity String
intoIdentity v = pure $ "{" ++ v ++ "}"

printFocus :: (Show a, Functor m) => (a -> m a') -> Lens s s' a a' -> s -> m s'
printFocus f lens struct = lens f struct

doMain :: Monad m => (String -> m String) -> Person -> m Person'
doMain f p = do
  p <- printFocus f (field @ "name") p
  p <- printFocus f (field @ "eye_color") p
  printFocus (f . show) ageT p

doMainWorks :: Bool
doMainWorks = (runIdentity $ doMain intoIdentity person) == Person' "{Bob}" "{12}" "{hazel}"

person = Person "Bob" 12 "hazel"
main :: IO ()
main = do
  doMain printAndReturn person
  putStrLn $ "works? " ++ (show doMainWorks)