Complete chapter 22

22-reader/22.11-chapter-excercises.md

@@ -0,0 +1,10 @@
+# Chapter Excercises
+## A warmup stretch
+see src/ReaderPractise
+
+## Rewriting Shawty
+No idea if this is correct.
+
+see shawty-prime/app/Main.hs
+
+I can create a `ReaderT` from `app` and that works, but I can't do the same with `saveURI` and `getURI` and find how to connect it up with `app`.

22-reader/22.2-warming-up.md

@@ -0,0 +1,2 @@
+# Short Exercise: Warming Up
+see src/warmingup.hs

22-reader/22.5-ask.md

@@ -0,0 +1,2 @@
+# Excercise: Ask
+see src/ask.hs

22-reader/22.6-reading-comprehension.md

@@ -0,0 +1,2 @@
+# Exercise: Reading Comprehension
+see src/readingcomp.hs

22-reader/22.7-reader-monad.md

@@ -0,0 +1,2 @@
+# Exercise: Reader Monad
+see src/readingcomp.hs

22-reader/shawty-prime/LICENSE

@@ -0,0 +1,30 @@
+Copyright Chris Allen (c) 2015
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Chris Allen nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

22-reader/shawty-prime/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

22-reader/shawty-prime/app/Main.hs

@@ -0,0 +1,116 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import Control.Monad (replicateM)
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.ByteString.Char8 as BC
+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
+import qualified Data.Text.Lazy as TL
+import qualified Database.Redis as R
+import Network.URI (URI, parseURI)
+import qualified System.Random as SR
+import Web.Scotty
+
+import Control.Monad.Reader (ReaderT(..), runReaderT, ask, lift)
+
+alphaNum :: String
+alphaNum = ['A'..'Z'] ++ ['0'..'9']
+
+randomElement :: String -> IO Char
+randomElement xs = do
+  let maxIndex :: Int
+      maxIndex = length xs - 1
+  -- Right of arrow is IO Int, so randomDigit is Int
+  randomDigit <- SR.randomRIO (0, maxIndex) :: IO Int
+  return (xs !! randomDigit)
+
+shortyGen :: IO String
+shortyGen =
+  replicateM 7 (randomElement alphaNum)
+
+saveURI :: R.Connection
+        -> BC.ByteString
+        -> BC.ByteString
+        -> IO (Either R.Reply R.Status)
+saveURI conn shortURI uri =
+  R.runRedis conn $ R.set shortURI uri
+
+-- No idea how to use this now...
+saveURI' :: BC.ByteString 
+        -> BC.ByteString 
+        -> ReaderT R.Connection IO (Either R.Reply R.Status)
+saveURI' shortURI uri = do
+  conn <- ask
+  liftIO $ R.runRedis conn $ R.set shortURI uri
+
+getURI  :: R.Connection
+        -> BC.ByteString
+        -> IO (Either R.Reply (Maybe BC.ByteString))
+getURI conn shortURI = R.runRedis conn $ R.get shortURI
+
+-- No idea how to use this now...
+getURI' :: BC.ByteString
+       -> ReaderT R.Connection IO (Either R.Reply (Maybe BC.ByteString))
+getURI' shortURI = do
+  conn <- ask
+  liftIO $ R.runRedis conn $ R.get shortURI
+
+linkShorty :: String -> String
+linkShorty shorty =
+  concat [ "<a href=\""
+         , shorty
+         , "\">Copy and paste your short URL</a>"
+         ]
+
+shortyCreated :: Show a => a -> String -> TL.Text
+shortyCreated resp shawty =
+  TL.concat [ TL.pack (show resp)
+            , " shorty is: ", TL.pack (linkShorty shawty)
+            ]
+
+shortyAintUri :: TL.Text -> TL.Text
+shortyAintUri uri =
+  TL.concat [ uri
+            , " wasn't a url, did you forget http://?"
+            ]
+
+shortyFound :: TL.Text -> TL.Text
+shortyFound tbs =
+  TL.concat ["<a href=\"", tbs, "\">", tbs, "</a>"]
+
+app :: ReaderT R.Connection ScottyM ()
+app =  do
+  rConn <- ask
+  lift $ do 
+    get "/" $ do
+      uri <- param "uri"
+      let parsedUri :: Maybe URI
+          parsedUri = parseURI (TL.unpack uri)
+      case parsedUri of
+        Just _  -> do
+          shawty <- liftIO shortyGen
+          let shorty = BC.pack shawty
+              uri' = encodeUtf8 (TL.toStrict uri)
+          resp <- liftIO (saveURI rConn shorty uri')
+          html (shortyCreated resp shawty)
+        Nothing -> text (shortyAintUri uri)
+    get "/:short" $ do
+      short <- param "short"
+      uri <- liftIO (getURI rConn short)
+      case uri of
+        Left reply -> text (TL.pack (show reply))
+        Right mbBS -> case mbBS of
+          Nothing -> text "uri not found"
+          Just bs -> html (shortyFound tbs)
+            where tbs :: TL.Text
+                  tbs = TL.fromStrict (decodeUtf8 bs)
+
+main :: IO ()
+main = do
+  rConn <- R.connect R.defaultConnectInfo
+  scotty 3000 $ runReaderT app rConn 
+-- main = do
+--   rConn <- R.connect R.defaultConnectInfo
+--   scotty 3000 (app rConn)
+

22-reader/shawty-prime/shawty.cabal

@@ -0,0 +1,33 @@
+name:                shawty
+version:             0.1.0.0
+synopsis:            Initial project template from stack
+description:         Please see README.md
+homepage:            http://github.com/bitemyapp/shawty#readme
+license:             BSD3
+license-file:        LICENSE
+author:              Chris Allen
+maintainer:          cma@bitemyapp.com
+copyright:           2015, Chris Allen
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.10
+
+executable shawty
+  hs-source-dirs:      app
+  main-is:             Main.hs
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  build-depends:       base
+                     , bytestring
+                     , hedis
+                     , mtl
+                     , network-uri
+                     , random
+                     , scotty
+                     , semigroups
+                     , text
+                     , transformers
+  default-language:    Haskell2010
+
+source-repository head
+  type:     git
+  location: https://github.com/bitemyapp/shawty-prime

22-reader/shawty-prime/stack.yaml

@@ -0,0 +1,32 @@
+# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md
+
+# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
+resolver: lts-3.7
+
+# Local packages, usually specified by relative directory name
+packages:
+- '.'
+
+# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
+extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+flags: {}
+
+# Extra package databases containing global packages
+extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: >= 0.1.4.0
+
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]

22-reader/src/ReaderPractice.hs

@@ -0,0 +1,57 @@
+module ReaderPractice where
+
+import Control.Applicative
+import Data.Maybe
+
+x :: [Integer]
+x = [1, 2, 3]
+y :: [Integer]
+y = [4, 5, 6]
+z :: [Integer]
+z = [7, 8, 9]
+
+xs :: Maybe Integer
+xs = lookup 3 $ zip x y
+
+ys :: Maybe Integer
+ys = lookup 6 $ zip y z
+
+zs :: Maybe Integer
+zs = lookup 4 $ zip x y
+
+z' :: Integer -> Maybe Integer
+z' n = lookup n $ zip x z
+
+x1 :: Maybe (Integer, Integer)
+x1 = liftA2 (,) xs ys
+
+x2 :: Maybe (Integer, Integer)
+x2 = liftA2 (,) ys zs
+
+x3 :: Integer -> (Maybe Integer, Maybe Integer)
+x3 = liftA2 (,) z' z'
+
+summed :: Num c => (c, c) -> c
+summed = uncurry (+)
+
+bolt :: Integer -> Bool
+bolt = liftA2 (&&) (>3) (<8)
+
+sequA :: Integral a => a -> [Bool]
+sequA m = sequenceA [(>3), (<8), even] m
+
+s' :: Maybe Integer
+s' = summed <$> ((,) <$> xs <*> ys)
+
+main :: IO ()
+main = do
+    -- print $ sequenceA [Just (3 :: Integer), Just 2, Just 1]
+    -- print $ sequenceA [x, y]
+    -- print $ sequenceA [xs, ys]
+    -- print $ summed <$> ((,) <$> xs <*> ys)
+    -- print $ fmap summed ((,) <$> xs <*> zs)
+    -- print $ bolt 7
+    -- print $ fmap bolt z
+    print $ and $ sequA (7 :: Integer)
+    print $ sequA $ fromMaybe 0 s'
+    print $ bolt $ fromMaybe 0 ys

22-reader/src/ask.hs

@@ -0,0 +1,6 @@
+module Ask where
+
+newtype Reader r a = Reader { runReader :: r -> a }
+
+ask :: Reader a a
+ask = Reader id

22-reader/src/follow.hs

@@ -0,0 +1,27 @@
+module Follow where
+
+import Control.Applicative
+
+boop :: Num a => a -> a
+boop = (*2)
+
+doop :: Num a => a -> a
+doop = (+10)
+
+bip :: Num a => a -> a
+bip = boop . doop
+
+bloop :: Num a => a -> a
+bloop = fmap boop doop
+
+bbop :: Num a => a -> a
+bbop = (+) <$> boop <*> doop
+
+duwop :: Num a => a -> a
+duwop = liftA2 (+) boop doop
+
+boopDoop :: Num a => a -> a
+boopDoop = do
+     a <- boop
+     b <- doop
+     return (a + b)

22-reader/src/monadfunc.hs

@@ -0,0 +1,26 @@
+module MonadFunc where
+
+foo :: (Functor f, Num a) => f a -> f a
+foo r = fmap (+1) r
+
+bar :: Foldable f => t -> f a -> (t, Int)
+bar r t = (r, length t)
+
+froot :: Num a => [a] -> ([a], Int)
+froot r  = (map (+1) r, length r)
+
+barOne :: Foldable t => t a -> (t a, Int)
+barOne r = (r, length r)
+
+barPlus :: (Foldable t, Functor t, Num a) => t a -> (t a, Int)
+barPlus r = (foo r, length r)
+
+frooty :: Num a => [a] -> ([a], Int)
+frooty r = bar (foo r) r
+
+frooty' :: Num a => [a] -> ([a], Int)
+frooty' = \r -> bar (foo r) r
+
+-- fooBind :: (t -> t1) -> (t1 -> t -> t2) -> t -> t2
+fooBind :: (r -> a) -> (a -> r -> b) -> r -> b
+fooBind m k = \r -> k (m r) r

22-reader/src/readingcomp.hs

@@ -0,0 +1,75 @@
+{-# LANGUAGE InstanceSigs #-}
+module ReadingComp where
+
+import Control.Applicative (liftA2)
+
+newtype Reader r a = Reader { runReader :: r -> a }
+
+instance Functor (Reader r) where
+    fmap f (Reader ra) = Reader $ f . ra
+
+-- 1
+myLiftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c
+myLiftA2 f a b = f <$> a <*> b
+
+-- 2
+asks :: (r -> a) -> Reader r a
+asks = Reader
+
+-- 3
+instance Applicative (Reader r) where
+    pure :: a -> Reader r a
+    pure a = Reader $ const a
+
+    (<*>) :: Reader r (a -> b) -> Reader r a -> Reader r b
+    (Reader rab) <*> (Reader ra) = Reader $ \r -> rab r $ ra r
+
+instance Monad (Reader r) where
+    return = pure
+    
+    (>>=) :: Reader r a -> (a -> Reader r b) -> Reader r b
+    (Reader ra) >>= aRb = Reader $ \r -> (runReader (aRb (ra r))) r
+
+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")
+
+mario :: Person
+mario = Person (HumanName "Mario")
+                (DogName "Yoshi")
+                (Address "Mushroom Kingdom")
+            
+getDog :: Person -> Dog
+getDog p = Dog (dogName p) (address p)
+
+getDogR :: Person -> Dog
+getDogR = Dog <$> dogName <*> address
+
+getDogR' :: Person -> Dog
+getDogR' = liftA2 Dog dogName address
+
+getDogRM :: Person -> Dog
+getDogRM = do
+    name <- dogName
+    addy <- address
+    return $ Dog name addy
+
+getDogRM' :: Reader Person Dog
+getDogRM' = do
+    name <- Reader dogName
+    addy <- Reader address
+    return $ Dog name addy

22-reader/src/warmingup.hs

@@ -0,0 +1,27 @@
+module WarmingUp where
+
+import Data.Char
+
+cap :: [Char] -> [Char]
+cap = map toUpper
+
+rev :: [Char] -> [Char]
+rev = reverse
+
+composed :: [Char] -> [Char]
+composed = rev . cap
+
+fmapped :: [Char] -> [Char]
+fmapped = fmap cap rev
+
+tupled :: [Char] -> ([Char],[Char])
+tupled = (,) <$> cap <*> rev
+
+tupled' :: [Char] -> ([Char], [Char])
+tupled' = do
+    a <- cap
+    b <- rev
+    return (a, b)
+
+tupled'' :: [Char] -> ([Char],[Char])
+tupled'' = cap >>= \a -> rev >>= \b -> return (a,b)