foo.hs

{-# 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