subtree(users/wpcarro): docking briefcase at '24f5a642'

git-subtree-dir: users/wpcarro
git-subtree-mainline: 464bbcb15c
git-subtree-split: 24f5a642af
Change-Id: I6105b3762b79126b3488359c95978cadb3efa789

users/wpcarro/scratch/haskell-programming-from-first-principles/.envrc

@@ -0,0 +1,2 @@
+source_up
+use_nix

users/wpcarro/scratch/haskell-programming-from-first-principles/.ghci

@@ -0,0 +1 @@
+:set prompt "> "

users/wpcarro/scratch/haskell-programming-from-first-principles/applicative.hs

@@ -0,0 +1,213 @@
+module ApplicativeScratch where
+
+import Data.Function ((&))
+
+import Control.Applicative (liftA3)
+import qualified Data.List as List
+import qualified GHC.Base as Base
+
+--------------------------------------------------------------------------------
+
+-- xs :: [(Integer, Integer)]
+-- xs = zip [1..3] [4..6]
+
+-- added :: Maybe Integer
+-- added =
+--   (+3) <$> (lookup 3 xs)
+
+--------------------------------------------------------------------------------
+
+-- y :: Maybe Integer
+-- y = lookup 3 xs
+
+-- z :: Maybe Integer
+-- z = lookup 2 xs
+
+-- tupled :: Maybe (Integer, Integer)
+-- tupled = Base.liftA2 (,) y z
+
+--------------------------------------------------------------------------------
+
+-- x :: Maybe Int
+-- x = List.elemIndex 3 [1..5]
+
+-- y :: Maybe Int
+-- y = List.elemIndex 4 [1..5]
+
+-- maxed :: Maybe Int
+-- maxed = Base.liftA2 max x y
+
+--------------------------------------------------------------------------------
+
+xs = [1..3]
+ys = [4..6]
+
+x :: Maybe Integer
+x = lookup 3 $ zip xs ys
+
+y :: Maybe Integer
+y = lookup 2 $ zip xs ys
+
+summed :: Maybe Integer
+summed = sum <$> Base.liftA2 (,) x y
+
+--------------------------------------------------------------------------------
+
+newtype Identity a = Identity a deriving (Eq, Show)
+
+instance Functor Identity where
+  fmap f (Identity x) = Identity (f x)
+
+instance Applicative Identity where
+  pure = Identity
+  (Identity f) <*> (Identity x) = Identity (f x)
+
+--------------------------------------------------------------------------------
+
+newtype Constant a b =
+  Constant { getConstant :: a }
+  deriving (Eq, Ord, Show)
+
+instance Functor (Constant a) where
+  fmap _ (Constant x) = Constant x
+
+instance Monoid a => Applicative (Constant a) where
+  pure _ = Constant mempty
+  (Constant x) <*> (Constant y) = Constant (x <> y)
+
+--------------------------------------------------------------------------------
+
+one = const <$> Just "Hello" <*> Just "World"
+
+two :: Maybe (Integer, Integer, String, [Integer])
+two = (,,,) <$> (Just 90)
+            <*> (Just 10)
+            <*> (Just "Tierness")
+            <*> (Just [1..3])
+
+--------------------------------------------------------------------------------
+
+data List a = Nil | Cons a (List a) deriving (Eq, Show)
+
+instance Semigroup (List a) where
+  Nil <> xs = xs
+  xs <> Nil = xs
+  (Cons x xs) <> ys = Cons x (xs <> ys)
+
+instance Functor List where
+  fmap f Nil = Nil
+  fmap f (Cons x xs) = Cons (f x) (fmap f xs)
+
+instance Applicative List where
+  pure x = Cons x Nil
+  Nil <*> _ = Nil
+  _ <*> Nil = Nil
+  (Cons f fs) <*> xs =
+    (f <$> xs) <> (fs <*> xs)
+
+toList :: List a -> [a]
+toList Nil = []
+toList (Cons x xs) = x : toList xs
+
+fromList :: [a] -> List a
+fromList [] = Nil
+fromList (x:xs) = Cons x (fromList xs)
+
+--------------------------------------------------------------------------------
+
+newtype ZipList' a =
+  ZipList' [a]
+  deriving (Eq, Show)
+
+-- instance Eq a => EqProp (ZipList' a) where
+--   (ZipList' lhs) =-= (ZipList' rhs) =
+--     (take 1000 lhs) `eq` (take 1000 rhs)
+
+instance Functor ZipList' where
+  fmap f (ZipList' xs) = ZipList' $ fmap f xs
+
+instance Applicative ZipList' where
+  pure x = ZipList' (repeat x)
+  (ZipList' fs) <*> (ZipList' xs) =
+    ZipList' $ zipWith ($) fs xs
+
+--------------------------------------------------------------------------------
+
+data Validation e a
+  = Failure e
+  | Success a
+  deriving (Eq, Show)
+
+instance Functor (Validation e) where
+  fmap f (Failure x) = Failure x
+  fmap f (Success x) = Success (f x)
+
+instance Monoid e => Applicative (Validation e) where
+  pure = undefined
+  (Success f) <*> (Success x) = Success (f x)
+  _ <*> (Failure x) = Failure x
+  (Failure x) <*> _ = Failure x
+
+data Error
+  = DivideByZero
+  | StackOverflow
+  deriving (Eq, Show)
+
+--------------------------------------------------------------------------------
+
+stops :: String
+stops = "pbtdkg"
+
+vowels :: String
+vowels = "aeiou"
+
+combos :: [a] -> [b] -> [c] -> [(a, b, c)]
+combos xs ys zs =
+  liftA3 (,,) xs ys zs
+
+--------------------------------------------------------------------------------
+
+data Pair a = Pair a a deriving Show
+
+instance Functor Pair where
+  fmap f (Pair x y) = Pair (f x) (f y)
+
+instance Applicative Pair where
+  pure x = Pair x x
+  (Pair f g) <*> (Pair x y) = Pair (f x) (g x)
+
+p :: Pair Integer
+p = Pair 1 2
+
+--------------------------------------------------------------------------------
+
+data Two a b = Two a b
+
+instance Functor (Two a) where
+  fmap f (Two x y) = Two x (f y)
+
+instance Monoid a => Applicative (Two a) where
+  pure x = Two mempty x
+  _ <*> _ = undefined
+
+--------------------------------------------------------------------------------
+
+data Three a b c = Three a b c
+
+instance Functor (Three a b) where
+  fmap f (Three x y z) = Three x y (f z)
+
+instance (Monoid a, Monoid b) => Applicative (Three a b) where
+  pure x = Three mempty mempty x
+  (Three a b f) <*> (Three x y z) = Three (a <> x) (b <> y) (f z)
+
+--------------------------------------------------------------------------------
+
+data Three' a b = Three' a b b
+
+instance Functor (Three' a) where
+  fmap f (Three' x y z) = Three' x (f y) (f z)
+
+instance Monoid a => Applicative (Three' a) where
+  pure x = Three' mempty x x
+  (Three' a f g) <*> (Three' x y z) = Three' (a <> x) (f y) (g z)

users/wpcarro/scratch/haskell-programming-from-first-principles/basic-libraries.hs

@@ -0,0 +1,60 @@
+module BasicLibrariesScratch where
+
+import Data.Function ((&))
+
+--------------------------------------------------------------------------------
+newtype DList a = DL { unDL :: [a] -> [a] }
+
+instance (Show a) => Show (DList a) where
+  show (DL x) = "DL " ++ show (x [])
+
+-- | Create an empty difference list.
+emptyDList :: DList a
+emptyDList = DL $ \xs -> xs
+{-# INLINE emptyDList #-}
+
+-- | Create a difference list with `x` as the only member.
+singleton :: a -> DList a
+singleton x =  DL $ \xs -> x : xs
+{-# INLINE singleton #-}
+
+-- | Convert the DList into a list.
+toList :: DList a -> [a]
+toList (DL unDL) = unDL mempty
+{-# INLINE toList #-}
+
+-- | Add an element to the end of a DList.
+infixr `snoc`
+snoc :: a -> DList a -> DList a
+snoc x (DL xs) = DL $ \ys -> xs (x : ys)
+{-# INLINE snoc #-}
+
+-- | Add an element to the beginning of a DList.
+infixr `cons`
+cons :: a -> DList a -> DList a
+cons x (DL xs) = DL $ \ys -> x : xs ys
+{-# INLINE cons #-}
+
+-- | Combine two DLists together.
+append :: DList a -> DList a -> DList a
+append (DL xs) (DL ys) = DL $ \zs -> zs & ys & xs
+{-# INLINE append #-}
+
+--------------------------------------------------------------------------------
+data Queue a =
+  Queue { one :: [a]
+        , two :: [a]
+        } deriving (Show, Eq)
+
+emptyQueue :: Queue a
+emptyQueue = Queue mempty mempty
+
+enqueue :: a -> Queue a -> Queue a
+enqueue x (Queue en de) = Queue (x:en) de
+
+dequeue :: Queue a -> Maybe (a, Queue a)
+dequeue (Queue [] []) = Nothing
+dequeue (Queue en []) =
+  let (d:de) = reverse en
+  in Just (d, Queue de [])
+dequeue (Queue en (d:de)) = Just (d, Queue en de)

users/wpcarro/scratch/haskell-programming-from-first-principles/composing-types.hs

@@ -0,0 +1,75 @@
+module ComposingTypesScratch where
+
+import Data.Function ((&))
+import Data.Bifunctor
+
+import qualified Data.Foldable as F
+
+--------------------------------------------------------------------------------
+
+newtype Identity a =
+  Identity { getIdentity :: a }
+  deriving (Eq, Show)
+
+newtype Compose f g a =
+  Compose { getCompose :: f (g a) }
+  deriving (Eq, Show)
+
+--------------------------------------------------------------------------------
+
+instance (Functor f, Functor g) => Functor (Compose f g) where
+  fmap f (Compose getCompose) = Compose $ (fmap . fmap) f getCompose
+
+instance (Applicative f, Applicative g) => Applicative (Compose f g) where
+  pure x = x & pure & pure & Compose
+  fgf <*> fga = undefined
+
+--------------------------------------------------------------------------------
+
+instance (Foldable f, Foldable g) => Foldable (Compose f g) where
+  foldMap toMonoid x = undefined
+
+instance (Traversable f, Traversable g) => Traversable (Compose f g) where
+  traverse = undefined
+
+--------------------------------------------------------------------------------
+
+data Deux a b = Deux a b deriving (Show, Eq)
+
+instance Bifunctor Deux where
+  bimap f g (Deux x y) = Deux (f x) (g y)
+
+data Const a b = Const a deriving (Show, Eq)
+
+instance Bifunctor Const where
+  bimap f _ (Const x) = Const (f x)
+
+data Drei a b c = Drei a b c deriving (Show, Eq)
+
+instance Bifunctor (Drei a) where
+  bimap f g (Drei x y z) = Drei x (f y) (g z)
+
+data SuperDrei a b c = SuperDrei a b deriving (Show, Eq)
+
+instance Bifunctor (SuperDrei a) where
+  bimap f g (SuperDrei x y) = SuperDrei x (f y)
+
+data SemiDrei a b c = SemiDrei a deriving (Show, Eq)
+
+instance Bifunctor (SemiDrei a) where
+  bimap _ _ (SemiDrei x) = SemiDrei x
+
+data Quadriceps a b c d = Quadzzz a b c d
+
+instance Bifunctor (Quadriceps a b) where
+  bimap f g (Quadzzz w x y z) = Quadzzz w x (f y) (g z)
+
+-- | Analogue for Either
+data LeftRight a b
+  = Failure a
+  | Success b
+  deriving (Show, Eq)
+
+instance Bifunctor LeftRight where
+  bimap f _ (Failure x) = Failure (f x)
+  bimap _ g (Success y) = Success (g y)

users/wpcarro/scratch/haskell-programming-from-first-principles/foldable.hs

@@ -0,0 +1,107 @@
+module FoldableScratch where
+
+import Data.Function ((&))
+
+--------------------------------------------------------------------------------
+
+sum :: (Foldable t, Num a) => t a -> a
+sum xs =
+  foldr (+) 0 xs
+
+product :: (Foldable t, Num a) => t a -> a
+product xs =
+  foldr (*) 1 xs
+
+elem :: (Foldable t, Eq a) => a -> t a -> Bool
+elem y xs =
+  foldr (\x acc -> if acc then acc else y == x) False xs
+
+minimum :: (Foldable t, Ord a) => t a -> Maybe a
+minimum xs =
+  foldr (\x acc ->
+           case acc of
+             Nothing   -> Just x
+             Just curr -> Just (min curr x)) Nothing xs
+
+maximum :: (Foldable t, Ord a) => t a -> Maybe a
+maximum xs =
+  foldr (\x acc ->
+           case acc of
+             Nothing   -> Nothing
+             Just curr -> Just (max curr x)) Nothing xs
+
+-- TODO: How could I use QuickCheck to see if Prelude.null and this null return
+-- the same results for the same inputs?
+null :: (Foldable t) => t a -> Bool
+null xs =
+  foldr (\_ _ -> False) True xs
+
+length :: (Foldable t) => t a -> Int
+length xs =
+  foldr (\_ acc -> acc + 1) 0 xs
+
+toList :: (Foldable t) => t a -> [a]
+toList xs =
+  reverse $ foldr (\x acc -> x : acc) [] xs
+
+fold :: (Foldable t, Monoid m) => t m -> m
+fold xs =
+  foldr mappend mempty xs
+
+foldMap :: (Foldable t, Monoid m) => (a -> m) -> t a -> m
+foldMap f xs =
+  foldr (\x acc -> mappend (f x) acc) mempty xs
+
+--------------------------------------------------------------------------------
+
+data List a = Nil | Cons a (List a) deriving (Eq, Show)
+
+instance Foldable List where
+  foldr f acc (Cons x rest) = foldr f (f x acc) rest
+  foldr f acc Nil = acc
+
+fromList :: [a] -> List a
+fromList [] = Nil
+fromList (x:rest) = Cons x (fromList rest)
+
+--------------------------------------------------------------------------------
+
+data Constant a b = Constant b deriving (Eq, Show)
+
+-- TODO: Is this correct?
+instance Foldable (Constant a) where
+  foldr f acc (Constant x) = f x acc
+
+--------------------------------------------------------------------------------
+
+data Two a b = Two a b deriving (Eq, Show)
+
+instance Foldable (Two a) where
+  foldr f acc (Two x y) = f y acc
+
+--------------------------------------------------------------------------------
+
+data Three a b c = Three a b c deriving (Eq, Show)
+
+instance Foldable (Three a b) where
+  foldr f acc (Three x y z) = f z acc
+
+--------------------------------------------------------------------------------
+
+data Three' a b = Three' a b b deriving (Eq, Show)
+
+instance Foldable (Three' a) where
+  foldr f acc (Three' x y z) = acc & f z & f y
+
+--------------------------------------------------------------------------------
+
+data Four' a b = Four' a b b b deriving (Eq, Show)
+
+instance Foldable (Four' a) where
+  foldr f acc (Four' w x y z) = acc & f z & f y & f x
+
+--------------------------------------------------------------------------------
+
+filterF :: (Applicative f, Foldable t, Monoid (f a)) => (a -> Bool) -> t a -> f a
+filterF pred xs =
+  foldr (\x acc -> if pred x then pure x `mappend` acc else acc) mempty xs

users/wpcarro/scratch/haskell-programming-from-first-principles/io.hs

@@ -0,0 +1,35 @@
+module IOScratch where
+
+import qualified System.Environment as SE
+import qualified System.IO as SIO
+--------------------------------------------------------------------------------
+
+docs :: String
+docs = "Pass -e to encrypt and -d to decrypt."
+
+encryptStdin :: IO ()
+encryptStdin = do
+  char <- SIO.hGetChar SIO.stdin
+  -- encrypt char
+  SIO.hPutStr SIO.stdout [char]
+
+decryptStdin :: IO ()
+decryptStdin = do
+  char <- SIO.hGetChar SIO.stdin
+  -- decrypt char
+  SIO.hPutStr SIO.stdout [char]
+
+main :: IO ()
+main = do
+  args <- SE.getArgs
+  case args of
+    [] ->
+      putStrLn $ "You did not pass enough arguments. " ++ docs
+    ["-e"] ->
+      encryptStdin
+    ["-d"] ->
+      decryptStdin
+    [x] ->
+      putStrLn $ "You passed an unsupported option: " ++ x ++ ". " ++ docs
+    _ ->
+      putStrLn $ "You passed too many arguments. " ++ docs

users/wpcarro/scratch/haskell-programming-from-first-principles/monad-transformers.hs

@@ -0,0 +1,183 @@
+module MonadTransformersScratch where
+
+import Control.Monad
+import qualified Control.Monad.Trans.Maybe as M
+import qualified Control.Monad.Trans.Reader as R
+import qualified Control.Monad.Trans.State as S
+import Data.Function ((&))
+--------------------------------------------------------------------------------
+
+newtype MaybeT m a =
+  MaybeT { runMaybeT :: m (Maybe a) }
+
+instance (Functor f) => Functor (MaybeT f) where
+  fmap f (MaybeT run) =
+    MaybeT $ (fmap . fmap) f run
+
+instance (Applicative m) => Applicative (MaybeT m) where
+  pure x = x & pure & pure & MaybeT
+  _ <*> _ = undefined
+
+instance (Monad m) => Monad (MaybeT m) where
+  return = pure
+  (MaybeT ma) >>= f = MaybeT $ do
+    maybeX <- ma
+    case maybeX of
+      Nothing -> pure Nothing
+      Just x -> x & f & runMaybeT
+
+--------------------------------------------------------------------------------
+
+newtype EitherT e m a =
+  EitherT { runEitherT :: m (Either e a) }
+
+instance (Functor m) => Functor (EitherT e m) where
+  fmap f (EitherT mEither) =
+    EitherT $ (fmap . fmap) f mEither
+
+instance (Applicative m) => Applicative (EitherT e m) where
+  pure x = EitherT $ (pure . pure) x
+  EitherT mEitherF <*> EitherT mEitherX =
+    EitherT $ (fmap (<*>) mEitherF) <*> mEitherX
+
+instance (Monad m) => Monad (EitherT e m) where
+  return = pure
+  EitherT mEitherX >>= f = EitherT $ do
+    eitherX <- mEitherX
+    case eitherX of
+      Left x -> pure $ Left x
+      Right x -> runEitherT $ f x
+
+swapEither :: Either l r -> Either r l
+swapEither (Left x) = Right x
+swapEither (Right x) = Left x
+
+swapEitherT :: (Functor m) => EitherT e m a -> EitherT a m e
+swapEitherT (EitherT mEitherX) =
+  EitherT $ fmap swapEither mEitherX
+
+eitherT :: Monad m => (a -> m c) -> (b -> m c) -> EitherT a m b -> m c
+eitherT aToMC bToMC (EitherT mEitherX) = do
+  eitherX <- mEitherX
+  case eitherX of
+    Left x -> aToMC x
+    Right x -> bToMC x
+
+--------------------------------------------------------------------------------
+
+newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a }
+
+instance (Functor m) => Functor (ReaderT r m) where
+  fmap f (ReaderT rma) =
+    ReaderT $ (fmap . fmap) f rma
+
+instance (Applicative m) => Applicative (ReaderT r m) where
+  pure x = x & pure & pure & ReaderT
+  ReaderT f <*> ReaderT x = ReaderT $ fmap (<*>) f <*> x
+
+-- instance (Monad m) => Monad (ReaderT r m) where
+--   return = pure
+--   ReaderT rma >>= f =
+--     ReaderT $ \r -> do
+--       a <- rma r
+--       runReaderT (f a) r
+-- --------------------------------------------------------------------------------
+
+rDec :: Num a => R.Reader a a
+rDec = R.ReaderT $ \x -> pure $ x + 1
+
+rShow :: Show a => R.Reader a String
+rShow = R.ReaderT $ \x -> pure $ show x
+
+rPrintAndInc :: (Num a, Show a) => R.ReaderT a IO a
+rPrintAndInc = R.ReaderT $ \x ->
+  putStrLn ("Hi: " ++ show x) >> pure (x + 1)
+
+sPrintIncAccum :: (Num a, Show a) => S.StateT a IO String
+sPrintIncAccum = S.StateT $ \x -> do
+  putStrLn ("Hi: " ++ show x)
+  pure (show x, x + 1)
+
+--------------------------------------------------------------------------------
+
+isValid :: String -> Bool
+isValid v = '!' `elem` v
+
+maybeExcite :: M.MaybeT IO String
+maybeExcite = M.MaybeT $ do
+  x <- getLine
+  putStrLn ""
+  case isValid x of
+    False -> pure Nothing
+    True -> pure $ Just x
+
+doExcite :: IO ()
+doExcite = do
+  putStr "Say something *exciting*: "
+  excite <- M.runMaybeT maybeExcite
+  case excite of
+    Nothing -> putStrLn "Gonna need some more excitement..."
+    Just x  -> putStrLn "Now THAT'S exciting...nice!"
+
+--------------------------------------------------------------------------------
+
+data Participant
+  = Man
+  | Machine
+  deriving (Show, Eq)
+
+newtype Hand = Hand (Integer, Integer) deriving (Show, Eq)
+
+newtype Score = Score (Integer, Integer) deriving (Show, Eq)
+
+getLineLn :: String -> IO String
+getLineLn prompt = do
+  putStr prompt
+  x <- getLine
+  putStrLn ""
+  pure x
+
+promptGuess :: IO Hand
+promptGuess = do
+  fingers <- getLineLn "How many fingers (0-5): "
+  guess <- getLineLn "Guess: "
+  pure $ Hand (read guess, read fingers)
+
+aiGuess :: IO Hand
+aiGuess = pure $ Hand (2, 3)
+
+whoWon :: Hand -> Hand -> Maybe Participant
+whoWon (Hand (guessA, fingersA)) (Hand (guessB, fingersB))
+  | guessA == guessB && guessA == (fingersA + fingersB) = Nothing
+  | guessA == (fingersA + fingersB) = Just Man
+  | guessB == (fingersA + fingersB) = Just Machine
+  | otherwise = Nothing
+
+initScore :: Score
+initScore = Score (0, 0)
+
+printScore :: Score -> IO ()
+printScore (Score (man, machine)) =
+  putStrLn $ "Man: " ++ show man ++ " Machine: " ++ show machine
+
+startMorra :: S.StateT Score IO ()
+startMorra = S.StateT $ \(Score (man, machine)) -> do
+  Hand (guessA, fingersA) <- promptGuess
+  Hand (guessB, fingersB) <- aiGuess
+  putStrLn $ "P: " ++ show fingersA ++ "," ++ show guessA
+  putStrLn $ "C: " ++ show fingersB ++ "," ++ show guessB
+  case whoWon (Hand (guessA, fingersA)) (Hand (guessB, fingersB)) of
+    Nothing -> do
+      putStrLn "Nobody won..."
+      printScore (Score (man, machine))
+      pure ((), Score (man, machine))
+    Just Man -> do
+      putStrLn "Man won!"
+      printScore (Score (man + 1, machine))
+      pure ((), Score (man + 1, machine))
+    Just Machine -> do
+      putStrLn "Oh no... Machine won..."
+      printScore (Score (man, machine + 1))
+      pure ((), Score (man, machine + 1))
+
+playMorra = S.runStateT (forever startMorra) initScore

users/wpcarro/scratch/haskell-programming-from-first-principles/monad.hs

@@ -0,0 +1,178 @@
+module MonadScratch where
+
+import Data.Function ((&))
+import Test.QuickCheck
+import Test.QuickCheck.Checkers
+import Control.Applicative (liftA2)
+import qualified Control.Monad as Monad
+
+--------------------------------------------------------------------------------
+
+bind :: Monad m => (a -> m b) -> m a -> m b
+bind f x = Monad.join $ fmap f x
+
+--------------------------------------------------------------------------------
+
+fTrigger :: Functor f => f (Int, String, [Int])
+fTrigger = undefined
+
+aTrigger :: Applicative a => a (Int, String, [Int])
+aTrigger = undefined
+
+mTrigger :: Monad m => m (Int, String, [Int])
+mTrigger = undefined
+
+--------------------------------------------------------------------------------
+
+data Sum a b
+  = Fst a
+  | Snd b
+  deriving (Eq, Show)
+
+instance (Eq a, Eq b) => EqProp (Sum a b) where
+  (=-=) = eq
+
+instance (Arbitrary a, Arbitrary b) => Arbitrary (Sum a b) where
+  arbitrary = frequency [ (1, Fst <$> arbitrary)
+                        , (1, Snd <$> arbitrary)
+                        ]
+
+instance Functor (Sum a) where
+  fmap f (Fst x) = Fst x
+  fmap f (Snd x) = Snd (f x)
+
+instance Applicative (Sum a) where
+  pure x = Snd x
+  (Snd f) <*> (Snd x) = Snd (f x)
+  (Snd f) <*> (Fst x) = Fst x
+  (Fst x) <*> _ = Fst x
+
+instance Monad (Sum a) where
+  (Fst x) >>= _ = Fst x
+  (Snd x) >>= f = f x
+
+--------------------------------------------------------------------------------
+
+data Nope a = NopeDotJpg deriving (Eq, Show)
+
+instance Arbitrary (Nope a) where
+  arbitrary = pure NopeDotJpg
+
+instance EqProp (Nope a) where
+  (=-=) = eq
+
+instance Functor Nope where
+  fmap f _ = NopeDotJpg
+
+instance Applicative Nope where
+  pure _ = NopeDotJpg
+  _ <*> _ = NopeDotJpg
+
+instance Monad Nope where
+  NopeDotJpg >>= f = NopeDotJpg
+
+--------------------------------------------------------------------------------
+
+data BahEither b a
+  = PLeft a
+  | PRight b
+  deriving (Eq, Show)
+
+instance (Arbitrary b, Arbitrary a) => Arbitrary (BahEither b a) where
+  arbitrary = frequency [ (1, PLeft <$> arbitrary)
+                        , (1, PRight <$> arbitrary)
+                        ]
+
+instance (Eq a, Eq b) => EqProp (BahEither a b) where
+  (=-=) = eq
+
+instance Functor (BahEither b) where
+  fmap f (PLeft x) = PLeft (f x)
+  fmap _ (PRight x) = PRight x
+
+instance Applicative (BahEither b) where
+  pure = PLeft
+  (PRight x) <*> _ = PRight x
+  (PLeft f) <*> (PLeft x) = PLeft (f x)
+  _ <*> (PRight x) = PRight x
+
+instance Monad (BahEither b) where
+  (PRight x) >>= _ = PRight x
+  (PLeft x) >>= f = f x
+
+--------------------------------------------------------------------------------
+
+newtype Identity a = Identity a
+  deriving (Eq, Ord, Show)
+
+instance Functor Identity where
+  fmap f (Identity x) = Identity (f x)
+
+instance Applicative Identity where
+  pure = Identity
+  (Identity f) <*> (Identity x) = Identity (f x)
+
+instance Monad Identity where
+  (Identity x) >>= f = f x
+
+--------------------------------------------------------------------------------
+
+data List a
+  = Nil
+  | Cons a (List a)
+  deriving (Eq, Show)
+
+instance Arbitrary a => Arbitrary (List a) where
+  arbitrary = frequency [ (1, pure Nil)
+                        , (1, Cons <$> arbitrary <*> arbitrary)
+                        ]
+
+instance Eq a => EqProp (List a) where
+  (=-=) = eq
+
+fromList :: [a] -> List a
+fromList [] = Nil
+fromList (x:xs) = Cons x (fromList xs)
+
+instance Semigroup (List a) where
+  Nil <> xs = xs
+  xs <> Nil = xs
+  (Cons x xs) <> ys =
+    Cons x (xs <> ys)
+
+instance Functor List where
+  fmap f Nil = Nil
+  fmap f (Cons x xs) = Cons (f x) (fmap f xs)
+
+instance Applicative List where
+  pure x = Cons x Nil
+  Nil <*> _ = Nil
+  _ <*> Nil = Nil
+  (Cons f fs) <*> xs =
+    (f <$> xs) <> (fs <*> xs)
+
+instance Monad List where
+  Nil >>= _ = Nil
+  (Cons x xs) >>= f = (f x) <> (xs >>= f)
+
+--------------------------------------------------------------------------------
+
+j :: Monad m => m (m a) -> m a
+j = Monad.join
+
+l1 :: Monad m => (a -> b) -> m a -> m b
+l1 = Monad.liftM
+
+l2 :: Monad m => (a -> b -> c) -> m a -> m b -> m c
+l2 = Monad.liftM2
+
+a :: Monad m => m a -> m (a -> b) -> m b
+a = flip (<*>)
+
+meh :: Monad m => [a] -> (a -> m b) -> m [b]
+meh xs f = flipType $ f <$> xs
+
+flipType :: Monad m => [m a] -> m [a]
+flipType [] = pure mempty
+flipType (m:ms) =
+  m >>= (\x -> (x:) <$> flipType ms)

users/wpcarro/scratch/haskell-programming-from-first-principles/non-strictness.hs

@@ -0,0 +1,6 @@
+module NonStrictnessScratch where
+
+x = undefined
+y = "blah"
+main = do
+  print $ snd (x, x `seq` y)

users/wpcarro/scratch/haskell-programming-from-first-principles/reader.hs

@@ -0,0 +1,149 @@
+module Reader where
+
+import Data.Char
+import Data.Function ((&))
+import Data.Functor ((<&>))
+import qualified Control.Applicative as A
+import qualified Data.Maybe as MB
+
+cap :: String -> String
+cap xs = xs <&> toUpper
+
+rev :: String -> String
+rev = reverse
+
+compose :: String -> String
+compose xs = xs & rev . cap
+
+fmapped :: String -> String
+fmapped xs = xs & rev <$> cap
+
+tupled :: String -> (String, String)
+tupled xs = A.liftA2 (,) cap rev $ xs
+
+tupled' :: String -> (String, String)
+tupled' = do
+  capResult <- cap
+  revResult <- rev
+  pure (revResult, capResult)
+
+--------------------------------------------------------------------------------
+
+newtype Reader r a = Reader { runReader :: r -> a }
+
+ask :: Reader a a
+ask = Reader id
+
+--------------------------------------------------------------------------------
+
+newtype HumanName = HumanName String
+  deriving (Eq, Show)
+
+newtype DogName = DogName String
+  deriving (Eq, Show)
+
+newtype Address = Address String
+  deriving (Eq, Show)
+
+data Person
+  = Person
+  { humanName :: HumanName
+  , dogName :: DogName
+  , address :: Address
+  } deriving (Eq, Show)
+
+data Dog
+  = Dog
+  { dogsName :: DogName
+  , dogsAddress :: Address
+  } deriving (Eq, Show)
+
+pers :: Person
+pers =
+  Person (HumanName "Big Bird")
+         (DogName "Barkley")
+         (Address "Sesame Street")
+
+chris :: Person
+chris =
+  Person (HumanName "Chris Allen")
+         (DogName "Papu")
+         (Address "Austin")
+
+getDog :: Person -> Dog
+getDog p =
+  Dog (dogName p) (address p)
+
+getDogR :: Person -> Dog
+getDogR =
+  A.liftA2 Dog dogName address
+
+--------------------------------------------------------------------------------
+
+myLiftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c
+myLiftA2 f x y =
+  f <$> x <*> y
+
+asks :: (r -> a) -> Reader r a
+asks f = Reader f
+
+--------------------------------------------------------------------------------
+
+instance Functor (Reader a) where
+  fmap f (Reader ab) = Reader $ f . ab
+
+instance Applicative (Reader a) where
+  pure x = Reader $ \_ -> x
+  (Reader rab) <*> (Reader ra) = Reader $ do
+    ab <- rab
+    fmap ab ra
+
+--------------------------------------------------------------------------------
+
+instance Monad (Reader r) where
+  return = pure
+  -- (>>=) :: Reader r a -> (a -> Reader r b) -> Reader r b
+  (Reader x) >>= f = undefined
+
+--------------------------------------------------------------------------------
+
+x = [1..3]
+y = [4..6]
+z = [7..9]
+
+xs :: Maybe Integer
+xs = zip x y & lookup 3
+
+ys :: Maybe Integer
+ys = zip y z & lookup 6
+
+zs :: Maybe Integer
+zs = zip x y & lookup 4
+
+z' :: Integer -> Maybe Integer
+z' n = zip x y & lookup n
+
+x1 :: Maybe (Integer, Integer)
+x1 = A.liftA2 (,) xs ys
+
+x2 :: Maybe (Integer, Integer)
+x2 = A.liftA2 (,) ys zs
+
+x3 :: Integer -> (Maybe Integer, Maybe Integer)
+x3 n = (z' n, z' n)
+
+summed :: Num a => (a, a) -> a
+summed (x, y) = x + y
+
+bolt :: Integer -> Bool
+bolt x = x > 3 && x < 8
+
+main :: IO ()
+main = do
+  print $ sequenceA [Just 3, Just 2, Just 1]
+  print $ sequenceA [x, y]
+  print $ sequenceA [xs, ys]
+  print $ summed <$> ((,) <$> xs <*> ys)
+  print $ bolt 7
+  print $ bolt <$> z
+  print $ sequenceA [(>3), (<8) ,even] 7

users/wpcarro/scratch/haskell-programming-from-first-principles/shell.nix

@@ -0,0 +1,8 @@
+let
+  briefcase = import <briefcase> {};
+in briefcase.buildHaskell.shell {
+  deps = hpkgs: with hpkgs; [
+    quickcheck-simple
+    checkers
+  ];
+}

users/wpcarro/scratch/haskell-programming-from-first-principles/state.hs

@@ -0,0 +1,93 @@
+module StateScratch where
+
+--------------------------------------------------------------------------------
+import System.Random
+-- import Control.Monad.Trans.State
+import Data.Function ((&))
+
+import qualified Control.Applicative as Ap
+import qualified Control.Monad as M
+--------------------------------------------------------------------------------
+
+data Die
+  = DieOne
+  | DieTwo
+  | DieThree
+  | DieFour
+  | DieFive
+  | DieSix
+  deriving (Eq, Show)
+
+intToDie :: Integer -> Maybe Die
+intToDie 1 = Just DieOne
+intToDie 2 = Just DieTwo
+intToDie 3 = Just DieThree
+intToDie 4 = Just DieFour
+intToDie 5 = Just DieFive
+intToDie 6 = Just DieSix
+intToDie _ = Nothing
+
+rollDie :: Moi StdGen Die
+rollDie = do
+  (n, s) <- randomR (1, 6)
+  case intToDie n of
+    Just d  -> pure (d, s)
+    Nothing -> pure (DieOne, s)
+
+rollsToGetN :: Integer -> StdGen -> [Die]
+rollsToGetN n g = go 0 [] g
+  where
+    go sum result gen
+      | sum >= n = result
+      | otherwise =
+        let (dice, nextGen) = randomR (1, 6) gen
+        in case intToDie dice of
+          Nothing -> go (sum + dice) result nextGen
+          Just d  -> go (sum + dice) (d : result) nextGen
+
+--------------------------------------------------------------------------------
+
+newtype Moi s a = Moi { runMoi :: s -> (a, s) }
+
+instance Functor (Moi s) where
+  fmap f (Moi run) =
+    Moi $ \s -> let (x, t) = run s
+                in (f x, t)
+
+instance Applicative (Moi s) where
+  pure x = Moi $ \s -> (x, s)
+  (Moi f) <*> (Moi run) =
+    Moi $ \s -> let (g, t) = f s
+                    (x, u) = run t
+                in (g x, u)
+
+instance Monad (Moi s) where
+  (Moi run1) >>= f =
+    Moi $ \s -> let (x, t) = run1 s
+                    (Moi run2) = f x
+                in run2 t
+
+--------------------------------------------------------------------------------
+
+fizzBuzz :: Integer -> String
+fizzBuzz n | n `mod` 15 == 0 = "FizzBuzz"
+           | n `mod`  5 == 0 = "Buzz"
+           | n `mod`  3 == 0 = "Fizz"
+           | otherwise       = show n
+
+--------------------------------------------------------------------------------
+
+get :: Moi s s
+get = Moi $ \s -> (s, s)
+
+put :: s -> Moi s ()
+put x = Moi $ \s -> ((), x)
+
+exec :: Moi s a -> s -> s
+exec (Moi run) x = x & run & snd
+
+eval :: Moi s a -> s -> a
+eval (Moi run) x = x & run & fst
+
+modify :: (s -> s) -> Moi s ()
+modify f = Moi $ \s -> ((), f s)

users/wpcarro/scratch/haskell-programming-from-first-principles/traversable.hs

@@ -0,0 +1,131 @@
+module TraversableScratch where
+
+import qualified Data.Foldable as F
+
+import Test.QuickCheck
+
+newtype Identity a = Identity a
+  deriving (Eq, Ord, Show)
+
+instance Functor Identity where
+  fmap f (Identity x) = Identity (f x)
+
+instance Foldable Identity where
+  foldMap f (Identity x) = f x
+
+instance Traversable Identity where
+  traverse f (Identity x) = Identity <$> f x
+
+--------------------------------------------------------------------------------
+
+data Optional a
+  = Nada
+  | Some a
+  deriving (Eq, Show)
+
+instance Functor Optional where
+  fmap f Nada = Nada
+  fmap f (Some x) = Some (f x)
+
+instance Foldable Optional where
+  foldMap f Nada = mempty
+  foldMap f (Some x) = f x
+
+instance Traversable Optional where
+  traverse f Nada = pure Nada
+  traverse f (Some x) = Some <$> f x
+
+--------------------------------------------------------------------------------
+
+data List a = Nil | Cons a (List a) deriving (Eq, Show)
+
+instance Functor List where
+  fmap _ Nil = Nil
+  fmap f (Cons x xs) = Cons (f x) (fmap f xs)
+
+instance Foldable List where
+  foldMap f Nil = mempty
+  foldMap f (Cons x xs) = mappend (f x) (foldMap f xs)
+
+instance Traversable List where
+  sequenceA Nil = pure Nil
+  sequenceA (Cons x xs) = Cons <$> x <*> sequenceA xs
+
+--------------------------------------------------------------------------------
+
+data Three a b c = Three a b c
+  deriving (Eq, Show)
+
+instance Functor (Three a b) where
+  fmap f (Three x y z) = Three x y (f z)
+
+instance Foldable (Three a b) where
+  foldMap f (Three _ _ z) = f z
+
+instance Traversable (Three a b) where
+  sequenceA (Three x y z) = (\z' -> Three x y z') <$> z
+
+--------------------------------------------------------------------------------
+
+data Pair a b = Pair a b
+  deriving (Eq, Show)
+
+instance Functor (Pair a) where
+  fmap f (Pair x y) = Pair x (f y)
+
+instance Foldable (Pair a) where
+  foldMap f (Pair x y) = f y
+
+instance Traversable (Pair a) where
+  sequenceA (Pair x y) = (\y' -> Pair x y') <$> y
+
+--------------------------------------------------------------------------------
+
+data Big a b = Big a b b
+  deriving (Eq, Show)
+
+instance Functor (Big a) where
+  fmap f (Big x y z) = Big x (f y) (f z)
+
+instance Foldable (Big a) where
+  foldMap f (Big x y z) = f y <> f z
+
+instance Traversable (Big a) where
+  sequenceA (Big x y z) = (\y' z' -> Big x y' z') <$> y <*> z
+
+--------------------------------------------------------------------------------
+
+data Bigger a b = Bigger a b b b
+  deriving (Eq, Show)
+
+instance Functor (Bigger a) where
+  fmap f (Bigger w x y z) = Bigger w (f x) (f y) (f z)
+
+instance Foldable (Bigger a) where
+  foldMap f (Bigger w x y z) = f x <> f y <> f z
+
+instance Traversable (Bigger a) where
+  sequenceA (Bigger w x y z) = (\x' y' z' -> Bigger w x' y' z') <$> x <*> y <*> z
+
+--------------------------------------------------------------------------------
+
+data Tree a
+  = Empty
+  | Leaf a
+  | Node (Tree a) a (Tree a)
+  deriving (Eq, Show)
+
+instance Functor Tree where
+  fmap f Empty = Empty
+  fmap f (Leaf x) = Leaf (f x)
+  fmap f (Node lhs x rhs) = Node (fmap f lhs) (f x) (fmap f rhs)
+
+instance Foldable Tree where
+  foldMap f Empty = mempty
+  foldMap f (Leaf x) = f x
+  foldMap f (Node lhs x rhs) = (foldMap f lhs) <> (f x) <> (foldMap f rhs)
+
+instance Traversable Tree where
+  sequenceA Empty = pure Empty
+  sequenceA (Leaf x) = Leaf <$> x
+  sequenceA (Node lhs x rhs) = Node <$> sequenceA lhs <*> x <*> sequenceA rhs