Skip to content

Instantly share code, notes, and snippets.

@srid

srid/foo.hs Secret

Created Jan 5, 2020
Embed
What would you like to do?
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Entry where
import Control.Monad.Free
import Data.Barbie
import Data.Barbie.Bare
import Data.Barbie.TH
import Data.Time.Calendar
import GHC.Generics
import Lucid
import Relude
import qualified Rib.Parser.MMark as M
newtype Markdown = Markdown {unMarkdown :: Text}
deriving (Generic, Show)
data Mood
= Bad
| Neutral
| Good
deriving (Generic, Show, Eq, Bounded, Enum)
-- Salt is implicit.
data F
= Coffee Int
| M Meat Origin
| -- | Egg Int
-- | D Dairy
S Spice
deriving (Show, Eq, Ord, Generic)
data Spice
= Pepper
deriving (Show, Eq, Ord, Generic)
data Meat
= Beef Beef
| Seafood Seafood
deriving (Show, Eq, Ord, Generic)
data Beef
= Tallow
| Ribeye
| StripLoin
| GB
| GB_Wagyu
deriving (Show, Eq, Ord, Generic)
data Seafood
= SalmonWild
| ShrimpWild
| Scallop
deriving (Show, Eq, Ord, Generic)
-- Origin of some food.
data Origin
= Costco
| -- Pork is antibiotic-free. Wagyu too.
FlorentEtFils
| Fatworks
deriving (Show, Eq, Ord, Generic)
ffWagyu :: F
ffWagyu = M (Beef GB_Wagyu) FlorentEtFils
-- Fatworks Organic tallow
fwTallow :: F
fwTallow = M (Beef Tallow) Fatworks
costcoStrip :: F
costcoStrip = M (Beef StripLoin) Costco
costcoSalmonW :: F
costcoSalmonW = M (Seafood SalmonWild) Costco
costcoShrimpW :: F
costcoShrimpW = M (Seafood ShrimpWild) Costco
pepper :: F
pepper = S Pepper
someF :: [F]
someF = [costcoStrip, pepper]
declareBareB
[d|
data Entry'
= Entry'
{ skin :: Mood,
food :: [F],
note :: Maybe Markdown
}
|]
type Entry = Entry' Bare Identity
deriving instance Show Entry
deriving instance Show (Entry' Covered Maybe)
data EntryProgramF a
= SetNote Text a
| Skin Mood a
| AddFood F a
deriving (Functor)
type EntryProgram = Free EntryProgramF
setNote :: Text -> EntryProgram ()
setNote = instruction SetNote
setSkin :: Mood -> EntryProgram ()
setSkin = instruction Skin
addFood :: F -> EntryProgram ()
addFood = instruction AddFood
addFoods :: [F] -> EntryProgram ()
addFoods = mapM_ addFood
instruction :: Functor f => (t -> Free f () -> f (Free f a)) -> t -> Free f ()
instruction c a = void $ Free $ c a $ Pure ()
runEntry :: EntryProgram () -> Entry
runEntry prog = extract $ snd $ flip runState (Entry' Nothing Nothing (Just Nothing)) $ do
foldFree interpretEntry prog
where
extract :: Entry' Covered Maybe -> Entry
extract x = maybe (error $ "unfilled!:" <> show x) bstrip $ bsequence' x
interpretEntry :: EntryProgramF a -> State (Entry' Covered Maybe) a
interpretEntry = \case
SetNote s x -> do
modify $ \e -> e {note = Just (Just (Markdown s))}
pure x
Skin mood x -> do
modify $ \e -> e {skin = Just mood}
pure x
AddFood fx x -> do
modify $ \e -> e {food = Just (maybe [fx] (fx :) (food e))}
pure x
-- TODO: Figure out a free monad to building calendar of data?
-- x = do
-- onMonth (fromGregorian 2020 1) $ do
-- onDay 4 $ do
-- note "blah"
-- foods [Coffee 3, pepper]
-- foods
entries :: [(Day, Entry)]
entries =
[ ( fromGregorian 2020 1 4,
runEntry $ do
setSkin Neutral
common0
addFoods [costcoStrip, costcoSalmonW]
setNote "At one meal at 8pm today. Going forward, sticking to **2 regular sized meals**."
),
( fromGregorian 2020 1 5,
runEntry $ do
setSkin Neutral
common0
addFoods [ffWagyu, costcoShrimpW]
)
]
where
common0 = do
addFood $ Coffee 3
addFood $ fwTallow
addFood $ pepper
foodIcon :: F -> Html ()
foodIcon = \case
Coffee n -> forM_ [1 .. n] $ \_ -> fa "fas fa-coffee"
M (Beef _) _ -> "🐄"
M (Seafood _) _ -> fa "fas fa-fish"
S _ -> fa "fas fa-mortar-pestle"
where
fa :: (With (arg -> result), Term arg result, Monoid arg) => Text -> result
fa k = with i_ [class_ k] mempty
renderMarkdown :: Markdown -> Html ()
renderMarkdown = M.render . either error id . M.parsePure "<memory>" . unMarkdown
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment