From 9ed8fb2f6d742d028fdc31f570daa765fea473a8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Depreeuw?= Date: Thu, 9 Nov 2017 20:08:35 +0100 Subject: [PATCH] Complete chapter 22 --- 22-reader/22.11-chapter-excercises.md | 10 ++ 22-reader/22.2-warming-up.md | 2 + 22-reader/22.5-ask.md | 2 + 22-reader/22.6-reading-comprehension.md | 2 + 22-reader/22.7-reader-monad.md | 2 + 22-reader/shawty-prime/LICENSE | 30 ++++++ 22-reader/shawty-prime/Setup.hs | 2 + 22-reader/shawty-prime/app/Main.hs | 116 ++++++++++++++++++++++++ 22-reader/shawty-prime/shawty.cabal | 33 +++++++ 22-reader/shawty-prime/stack.yaml | 32 +++++++ 22-reader/src/ReaderPractice.hs | 57 ++++++++++++ 22-reader/src/ask.hs | 6 ++ 22-reader/src/follow.hs | 27 ++++++ 22-reader/src/monadfunc.hs | 26 ++++++ 22-reader/src/readingcomp.hs | 75 +++++++++++++++ 22-reader/src/warmingup.hs | 27 ++++++ 16 files changed, 449 insertions(+) create mode 100644 22-reader/22.11-chapter-excercises.md create mode 100644 22-reader/22.2-warming-up.md create mode 100644 22-reader/22.5-ask.md create mode 100644 22-reader/22.6-reading-comprehension.md create mode 100644 22-reader/22.7-reader-monad.md create mode 100644 22-reader/shawty-prime/LICENSE create mode 100644 22-reader/shawty-prime/Setup.hs create mode 100644 22-reader/shawty-prime/app/Main.hs create mode 100644 22-reader/shawty-prime/shawty.cabal create mode 100644 22-reader/shawty-prime/stack.yaml create mode 100644 22-reader/src/ReaderPractice.hs create mode 100644 22-reader/src/ask.hs create mode 100644 22-reader/src/follow.hs create mode 100644 22-reader/src/monadfunc.hs create mode 100644 22-reader/src/readingcomp.hs create mode 100644 22-reader/src/warmingup.hs diff --git a/22-reader/22.11-chapter-excercises.md b/22-reader/22.11-chapter-excercises.md new file mode 100644 index 0000000..5ecec18 --- /dev/null +++ b/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`. \ No newline at end of file diff --git a/22-reader/22.2-warming-up.md b/22-reader/22.2-warming-up.md new file mode 100644 index 0000000..91dc363 --- /dev/null +++ b/22-reader/22.2-warming-up.md @@ -0,0 +1,2 @@ +# Short Exercise: Warming Up +see src/warmingup.hs \ No newline at end of file diff --git a/22-reader/22.5-ask.md b/22-reader/22.5-ask.md new file mode 100644 index 0000000..1f65d09 --- /dev/null +++ b/22-reader/22.5-ask.md @@ -0,0 +1,2 @@ +# Excercise: Ask +see src/ask.hs \ No newline at end of file diff --git a/22-reader/22.6-reading-comprehension.md b/22-reader/22.6-reading-comprehension.md new file mode 100644 index 0000000..cd8bd86 --- /dev/null +++ b/22-reader/22.6-reading-comprehension.md @@ -0,0 +1,2 @@ +# Exercise: Reading Comprehension +see src/readingcomp.hs \ No newline at end of file diff --git a/22-reader/22.7-reader-monad.md b/22-reader/22.7-reader-monad.md new file mode 100644 index 0000000..4f786c2 --- /dev/null +++ b/22-reader/22.7-reader-monad.md @@ -0,0 +1,2 @@ +# Exercise: Reader Monad +see src/readingcomp.hs \ No newline at end of file diff --git a/22-reader/shawty-prime/LICENSE b/22-reader/shawty-prime/LICENSE new file mode 100644 index 0000000..5728243 --- /dev/null +++ b/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. \ No newline at end of file diff --git a/22-reader/shawty-prime/Setup.hs b/22-reader/shawty-prime/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/22-reader/shawty-prime/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/22-reader/shawty-prime/app/Main.hs b/22-reader/shawty-prime/app/Main.hs new file mode 100644 index 0000000..807c0ce --- /dev/null +++ b/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 [ "Copy and paste your short URL" + ] + +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 ["", tbs, ""] + +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) + diff --git a/22-reader/shawty-prime/shawty.cabal b/22-reader/shawty-prime/shawty.cabal new file mode 100644 index 0000000..44ff1ef --- /dev/null +++ b/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 diff --git a/22-reader/shawty-prime/stack.yaml b/22-reader/shawty-prime/stack.yaml new file mode 100644 index 0000000..2e43058 --- /dev/null +++ b/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] diff --git a/22-reader/src/ReaderPractice.hs b/22-reader/src/ReaderPractice.hs new file mode 100644 index 0000000..17a3527 --- /dev/null +++ b/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 diff --git a/22-reader/src/ask.hs b/22-reader/src/ask.hs new file mode 100644 index 0000000..f25a063 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/22-reader/src/follow.hs b/22-reader/src/follow.hs new file mode 100644 index 0000000..59079ff --- /dev/null +++ b/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) diff --git a/22-reader/src/monadfunc.hs b/22-reader/src/monadfunc.hs new file mode 100644 index 0000000..64ecfe4 --- /dev/null +++ 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 \ No newline at end of file diff --git a/22-reader/src/readingcomp.hs b/22-reader/src/readingcomp.hs new file mode 100644 index 0000000..779907e --- /dev/null +++ b/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 diff --git a/22-reader/src/warmingup.hs b/22-reader/src/warmingup.hs new file mode 100644 index 0000000..72cbc40 --- /dev/null +++ b/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)