1 files changed, 213 insertions, 0 deletions
diff --git a/scratch/haskell-programming-from-first-principles/applicative.hs b/scratch/haskell-programming-from-first-principles/applicative.hs
new file mode 100644
index 000000000000..8259606da374
--- /dev/null
+++ b/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)