Implement messages

Implement messages almost the same as in the Rust version, only with
YAML instead of TOML this time, and a regular old mustache template
instead of something handrolled. Besides that, pretty much everything
here is the same.
This commit is contained in:
Griffin Smith 2019-09-01 13:54:27 -04:00
parent 4ef19aa35a
commit 2fd3e4c9ad
13 changed files with 587 additions and 17 deletions

40
src/Xanthous/Random.hs Normal file
View file

@ -0,0 +1,40 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}
module Xanthous.Random
( Choose(..)
, ChooseElement(..)
) where
import Xanthous.Prelude
import Data.List.NonEmpty (NonEmpty)
import System.Random
import Control.Monad.Random.Class (MonadRandom(getRandomR))
class Choose a where
type RandomResult a
choose :: MonadRandom m => a -> m (RandomResult a)
newtype ChooseElement a = ChooseElement a
instance MonoFoldable a => Choose (ChooseElement a) where
type RandomResult (ChooseElement a) = Maybe (Element a)
choose (ChooseElement xs) = do
chosenIdx <- getRandomR (0, olength xs - 1)
let pick _ (Just x) = Just x
pick (x, i) Nothing
| i == chosenIdx = Just x
| otherwise = Nothing
pure $ ofoldr pick Nothing $ zip (toList xs) [0..]
instance MonoFoldable a => Choose (NonNull a) where
type RandomResult (NonNull a) = Element a
choose
= fmap (fromMaybe (error "unreachable")) -- why not lol
. choose
. ChooseElement
. toNullable
instance Choose (NonEmpty a) where
type RandomResult (NonEmpty a) = a
choose = choose . fromNonEmpty @[_]