diff options
Diffstat (limited to 'users/wpcarro/scratch/haskell-programming-from-first-principles')
14 files changed, 1241 insertions, 0 deletions
diff --git a/users/wpcarro/scratch/haskell-programming-from-first-principles/.envrc b/users/wpcarro/scratch/haskell-programming-from-first-principles/.envrc new file mode 100644 index 0000000000..a4a62da526 --- /dev/null +++ b/users/wpcarro/scratch/haskell-programming-from-first-principles/.envrc @@ -0,0 +1,2 @@ +source_up +use_nix diff --git a/users/wpcarro/scratch/haskell-programming-from-first-principles/.ghci b/users/wpcarro/scratch/haskell-programming-from-first-principles/.ghci new file mode 100644 index 0000000000..12aab7f08e --- /dev/null +++ b/users/wpcarro/scratch/haskell-programming-from-first-principles/.ghci @@ -0,0 +1 @@ +:set prompt "> " diff --git a/users/wpcarro/scratch/haskell-programming-from-first-principles/applicative.hs b/users/wpcarro/scratch/haskell-programming-from-first-principles/applicative.hs new file mode 100644 index 0000000000..8259606da3 --- /dev/null +++ b/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) diff --git a/users/wpcarro/scratch/haskell-programming-from-first-principles/basic-libraries.hs b/users/wpcarro/scratch/haskell-programming-from-first-principles/basic-libraries.hs new file mode 100644 index 0000000000..bb1f89987e --- /dev/null +++ b/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) diff --git a/users/wpcarro/scratch/haskell-programming-from-first-principles/composing-types.hs b/users/wpcarro/scratch/haskell-programming-from-first-principles/composing-types.hs new file mode 100644 index 0000000000..378cfb7cea --- /dev/null +++ b/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) diff --git a/users/wpcarro/scratch/haskell-programming-from-first-principles/foldable.hs b/users/wpcarro/scratch/haskell-programming-from-first-principles/foldable.hs new file mode 100644 index 0000000000..5b59d9e9ba --- /dev/null +++ b/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 diff --git a/users/wpcarro/scratch/haskell-programming-from-first-principles/io.hs b/users/wpcarro/scratch/haskell-programming-from-first-principles/io.hs new file mode 100644 index 0000000000..1de8937fce --- /dev/null +++ b/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 diff --git a/users/wpcarro/scratch/haskell-programming-from-first-principles/monad-transformers.hs b/users/wpcarro/scratch/haskell-programming-from-first-principles/monad-transformers.hs new file mode 100644 index 0000000000..3a780fc16c --- /dev/null +++ b/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 diff --git a/users/wpcarro/scratch/haskell-programming-from-first-principles/monad.hs b/users/wpcarro/scratch/haskell-programming-from-first-principles/monad.hs new file mode 100644 index 0000000000..2f80b457b1 --- /dev/null +++ b/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) diff --git a/users/wpcarro/scratch/haskell-programming-from-first-principles/non-strictness.hs b/users/wpcarro/scratch/haskell-programming-from-first-principles/non-strictness.hs new file mode 100644 index 0000000000..42608fb0c9 --- /dev/null +++ b/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) diff --git a/users/wpcarro/scratch/haskell-programming-from-first-principles/reader.hs b/users/wpcarro/scratch/haskell-programming-from-first-principles/reader.hs new file mode 100644 index 0000000000..7cb7b4a1bb --- /dev/null +++ b/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 diff --git a/users/wpcarro/scratch/haskell-programming-from-first-principles/shell.nix b/users/wpcarro/scratch/haskell-programming-from-first-principles/shell.nix new file mode 100644 index 0000000000..49dbe746d3 --- /dev/null +++ b/users/wpcarro/scratch/haskell-programming-from-first-principles/shell.nix @@ -0,0 +1,8 @@ +{ depot, ... }: + +depot.users.wpcarro.buildHaskell.shell { + deps = hpkgs: with hpkgs; [ + quickcheck-simple + checkers + ]; +} diff --git a/users/wpcarro/scratch/haskell-programming-from-first-principles/state.hs b/users/wpcarro/scratch/haskell-programming-from-first-principles/state.hs new file mode 100644 index 0000000000..f63e0ecdf1 --- /dev/null +++ b/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) diff --git a/users/wpcarro/scratch/haskell-programming-from-first-principles/traversable.hs b/users/wpcarro/scratch/haskell-programming-from-first-principles/traversable.hs new file mode 100644 index 0000000000..5dc4ea411b --- /dev/null +++ b/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 |