Skip to content

Instantly share code, notes, and snippets.

@fumieval
Created November 8, 2019 12:35
Show Gist options
  • Save fumieval/2313f9c5b9f1f0b62e451e0be0a8e96c to your computer and use it in GitHub Desktop.
Save fumieval/2313f9c5b9f1f0b62e451e0be0a8e96c to your computer and use it in GitHub Desktop.
{-# 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)
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment