From 2fd3e4c9ad28b77a0d167ceefe879ca80ee1ee04 Mon Sep 17 00:00:00 2001
From: Griffin Smith <root@gws.fyi>
Date: Sun, 1 Sep 2019 13:54:27 -0400
Subject: 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.
---
 src/Xanthous/Random.hs | 40 ++++++++++++++++++++++++++++++++++++++++
 1 file changed, 40 insertions(+)
 create mode 100644 src/Xanthous/Random.hs

(limited to 'src/Xanthous/Random.hs')

diff --git a/src/Xanthous/Random.hs b/src/Xanthous/Random.hs
new file mode 100644
index 000000000000..a3a1124f2780
--- /dev/null
+++ b/src/Xanthous/Random.hs
@@ -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 @[_]
-- 
cgit 1.4.1