simple-tangle.hs

{-# LANGUAGE RankNTypes, TemplateHaskell, GeneralizedNewtypeDeriving, DeriveGeneric #-}
module Main where

import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.IO.Class
import Control.Lens
import Data.Barbie
import GHC.Generics

newtype TangleT t m a = TangleT
  { unTangleT :: ReaderT (t (TangleT t m)) (StateT (t Maybe) m) a }
  deriving (Functor, Applicative, Monad, MonadIO)

hitch :: Monad m => (forall h. Lens' (t h) (h a)) -> TangleT t m a
hitch l = TangleT $ do
  mem <- get
  case view l mem of
    Just a -> return a
    Nothing -> do
      tangles <- ask
      a <- unTangleT $ view l tangles
      l .= Just a
      return a

runTangleT :: (ProductB t, Monad m) => t (TangleT t m) -> TangleT t m a -> m a
runTangleT ts (TangleT m) = m `runReaderT` ts `evalStateT` buniq Nothing

data Info h = Info
  { _height :: h Double
  , _mass :: h Double
  , _bmi :: h Double
  } deriving Generic
instance FunctorB Info
instance ProductB Info
makeLenses ''Info

buildInfo :: Info (TangleT Info IO)
buildInfo = Info
  { _height = liftIO $ putStr "Height(m): " >> readLn
  , _mass = liftIO $ putStr "Mass(kg): " >> readLn
  , _bmi = do
    h <- hitch height
    m <- hitch mass
    return $! m / (h * h)
  }