hid-examples 0.2 → 0.3

raw patch · 20 files changed

+723/−238 lines, 20 filesdep +directorydep +filepathdep +transformersdep ~hintnew-component:exe:dunew-component:exe:rpnexpr

Dependencies added: directory, filepath, transformers, unix-compat

Dependency ranges changed: hint

Files

• ChangeLog.md +9/−0
• README.md +1/−1
• du/App.hs +40/−0
• du/AppRWS.hs +23/−0
• du/DiskUsage.hs +40/−0
• du/FileCount.hs +24/−0
• du/TraverseDir.hs +27/−0
• du/du.hs +45/−0
• expr/EvalRPN.hs +34/−0
• expr/EvalRPN_trans.hs +47/−0
• expr/EvalRPN_trans2.hs +45/−0
• expr/MyMaybeT.hs +67/−0
• expr/rpnexpr.hs +27/−0
• expr/showexpr.hs +51/−0
• expr/shunting-yard.hs +177/−0
• hid-examples.cabal +42/−5
• package.yaml +21/−4
• showexpr.hs +0/−51
• shunting-yard.hs +0/−177
• stack.yaml +3/−0

@@ -3,3 +3,12 @@ ## 0.1.0.0  -- 2018-05-26  * Initial version. Examples for chapters 2 and 3.++## 0.2  -- 2018-08-24++* Examples for chapter 5.++## 0.3  -- 2018-11-13++* Examples for chapter 6. All examples of expressions processing+  are moved to folder 'expr'.

@@ -50,7 +50,7 @@ ### Building  ```-cabal sandox init+cabal sandbox init cabal install --only-dependencies cabal configure cabal build

@@ -0,0 +1,40 @@+{-# LANGUAGE GeneralizedNewtypeDeriving  #-}++module App where++import Control.Monad.Writer+import Control.Monad.Reader+import Control.Monad.State+import System.Posix.Types++data AppConfig = AppConfig {+      basePath :: FilePath,+      maxDepth :: Int,+      ext :: Maybe FilePath+    }++data AppState s = AppState {+      curDepth :: Int,+      curPath :: FilePath,+      st_field :: s+    }++type AppLog s = [(FilePath, s)]++newtype MyApp s a = MyApp {+      runApp :: ReaderT AppConfig +                  (WriterT (AppLog s)+                      (StateT (AppState s) +                                   IO)) a+    } deriving (Functor, Applicative, Monad,+                MonadIO,+                MonadReader AppConfig,+                MonadWriter (AppLog s),+                MonadState (AppState s))++runMyApp :: MyApp s a -> AppConfig -> s -> IO (a, AppLog s)+runMyApp app config init =+  evalStateT+         (runWriterT+               (runReaderT (runApp app) config))+         (AppState 0 (basePath config) init)

@@ -0,0 +1,23 @@+module AppRWS where++import Control.Monad.RWS++data AppConfig = AppConfig {+      basePath :: FilePath,+      maxDepth :: Int,+      ext :: Maybe FilePath+    }++data AppState s = AppState {+      curDepth :: Int,+      curPath :: FilePath,+      st_field :: s+    }++type AppLog s = [(FilePath, s)]++type MyApp s = RWST AppConfig (AppLog s) (AppState s) IO++runMyApp :: MyApp s a -> AppConfig -> s -> IO (a, AppLog s)+runMyApp app config init =+  evalRWST app config (AppState 0 (basePath config) init)

@@ -0,0 +1,40 @@+{-# LANGUAGE RecordWildCards, FlexibleContexts #-}++module DiskUsage (diskUsage) where++import Control.Monad.RWS+import System.FilePath (isExtensionOf)+import System.Posix.Types (FileOffset)+import System.PosixCompat.Files (FileStatus, getFileStatus,+                                 isDirectory, isRegularFile, fileSize)++import TraverseDir+import App++type DUApp = MyApp FileOffset++diskUsage :: DUApp ()+diskUsage = do+    maxDepth <- asks maxDepth+    AppState {..} <- get+    fs <- liftIO $ getFileStatus curPath+    let isDir = isDirectory fs+        shouldLog = isDir && curDepth <= maxDepth+    when isDir $ traverseDirectoryWith diskUsage+    recordEntry curPath fs +    when shouldLog $ logDiffTS st_field++recordEntry :: FilePath -> FileStatus -> DUApp ()+recordEntry fp fs = do+    ext <- asks ext+    when (needRec fp ext $ isRegularFile fs) (addToTS $ fileSize fs)+  where+--    addToTS :: FileOffset -> DUApp ()+    addToTS ofs = modify (\st -> st {st_field = st_field st + ofs})+    needRec _ Nothing _ = True+    needRec fp (Just ext) isFile = isFile && ext `isExtensionOf` fp++logDiffTS :: FileOffset -> DUApp ()+logDiffTS ts = do+    AppState {..} <- get+    tell [(curPath, st_field - ts)]

@@ -0,0 +1,24 @@+{-# LANGUAGE RecordWildCards #-}++module FileCount (fileCount) where++import Control.Monad.RWS+import System.FilePath+import System.Directory+import System.PosixCompat.Files++import TraverseDir+import App++fileCount :: MyApp Int ()+fileCount = do+    AppState {..} <- get+    fs <- liftIO $ getFileStatus curPath+    when (isDirectory fs) $ do+      AppConfig {..} <- ask+      when (curDepth <= maxDepth) $ traverseDirectoryWith fileCount+      files <- liftIO $ listDirectory curPath+      tell [(curPath, length $ filterFiles ext files)]+  where+    filterFiles Nothing = id+    filterFiles (Just ext) = filter (ext `isExtensionOf`)

@@ -0,0 +1,27 @@+{-# LANGUAGE RecordWildCards #-}++module TraverseDir (traverseDirectoryWith) where++import Data.Foldable (traverse_)+import Control.Monad.RWS+import System.Directory (listDirectory)+import System.FilePath ((</>))++import App++traverseDirectoryWith :: MyApp s () -> MyApp s ()+traverseDirectoryWith app = do+    path <- gets curPath+    content <- liftIO $ listDirectory path+    traverse_ (go path) content+  where+    go path name = do+      modify (newPath $ path </> name)+      app+      modify (restorePath $ path)+      +    newPath path st @ AppState {..} = st {curDepth = curDepth + 1,+                                          curPath = path}+    restorePath path st @ AppState {..} = st {curDepth = curDepth - 1,+                                              curPath = path}+

@@ -0,0 +1,45 @@+module Main where++import Data.Foldable+import Data.Monoid+import System.Environment++import Options.Applicative as Opt++import App+import DiskUsage+import FileCount++mkConfig :: Opt.Parser AppConfig+mkConfig = AppConfig+           <$> strArgument (metavar "DIRECTORY" <> value "." <> showDefault) +           <*> option auto (metavar "DEPTH" <> short 'd' <> long "depth"+               <> value 0 <> showDefault <> help "Maximum depth of reporting ")+           <*> optional+               (strOption (metavar "EXT" <> long "extension" <> short 'e'+                <> help "Filter files by extension"))++printLog :: Show s => AppLog s -> IO ()+printLog = traverse_ printEntry +  where+    printEntry (fp, s) = do+      putStr $ show s ++ "\t"+      putStrLn fp++++work :: AppConfig -> IO ()+work config = do+  (_, xs) <- runMyApp diskUsage config 0+  putStrLn "File space usage:"+  printLog xs++  (_, xs') <- runMyApp fileCount config 0+  putStrLn "File counter:"+  printLog xs'+  +  +main = execParser opts >>= work+  where+    opts = info (mkConfig <**> helper)+                (fullDesc <> progDesc "File space usage info")

@@ -0,0 +1,34 @@+module EvalRPN (evalRPN) where++import Control.Monad.State++{-+   Function evalRPN evaluates an expression given+   in the reversed polish notation (RPN, postfix notation):++   evalRPN "2 3 +" ==> 5 (== "2 + 3")+   evalRPN "2 3 4 + *" ==> 14 (== 2 * (3 + 4))+-}++type Stack = [Integer]++type EvalM = State Stack++push :: Integer -> EvalM ()+push x = modify (x:)++pop :: EvalM Integer+pop = do+  xs <- get+  put (tail xs)+  pure (head xs)++evalRPN :: String -> Integer+evalRPN expr = evalState evalRPN' []+  where+    evalRPN' = traverse step (words expr) >> pop+    step "+" = processTops (+)+    step "*" = processTops (*)+    step "-" = processTops (-)+    step t  = push (read t)+    processTops op = flip op <$> pop <*> pop >>= push

@@ -0,0 +1,47 @@+module EvalRPN_trans (evalRPN) where++import Control.Monad.State++import Safe++{-+   Function evalRPN evaluates an expression given+   in the reversed polish notation (RPN, postfix notation):++   evalRPN "2 3 +" ==> 5 (== "2 + 3")+   evalRPN "2 3 4 + *" ==> 14 (== 2 * (3 + 4))+-}++type Stack = [Integer]++type EvalM = StateT Stack Maybe++push :: Integer -> EvalM ()+push x = modify (x:)++pop :: EvalM Integer+pop = do+  xs <- get+  guard (not $ null xs)+  put (tail xs)+  pure (head xs)+--  lift (headMay xs)+  ++oneElementOnStack :: EvalM ()+oneElementOnStack = do+  l <- length <$> get+  guard (l == 1)+--  when (l /= 1) $ lift Nothing++readSafe :: String -> EvalM Integer+readSafe s = lift (readMay s)++evalRPN :: String -> Maybe Integer+evalRPN str = evalStateT evalRPN' []+  where+    evalRPN' = traverse step (words str) >> oneElementOnStack >> pop+    step "+" = processTops (+)+    step "*" = processTops (*)+    step t   = readSafe t >>= push+    processTops op = op <$> pop <*> pop >>= push

@@ -0,0 +1,45 @@+module EvalRPN_trans2 (evalRPN) where++import Control.Monad.State+--import Control.Monad.Trans.Maybe+import MyMaybeT+import Safe++{-+   Function evalRPN evaluates an expression given+   in the reversed polish notation (RPN, postfix notation):++   evalRPN "2 3 +" ==> 5 (== "2 + 3")+   evalRPN "2 3 4 + *" ==> 14 (== 2 * (3 + 4))+-}++type Stack = [Integer]++type EvalM = MaybeT (State Stack)++push :: Integer -> EvalM ()+push x = modify (x:)++pop :: EvalM Integer+pop = do+  xs <- get+  guard (not $ null xs)+  put (tail xs)+  pure (head xs)++oneElementOnStack :: EvalM ()+oneElementOnStack = do+  l <- length <$> get+  guard (l == 1)++readSafe :: String -> EvalM Integer+readSafe s = MaybeT . pure $ readMay s++evalRPN :: String -> Maybe Integer+evalRPN str = evalState (runMaybeT evalRPN') []+  where+    evalRPN' = traverse step (words str) >> oneElementOnStack >> pop+    step "+" = processTops (+)+    step "*" = processTops (*)+    step t   = readSafe t >>= push+    processTops op = op <$> pop <*> pop >>= push

@@ -0,0 +1,67 @@+{-# LANGUAGE+  FlexibleInstances+  , MultiParamTypeClasses+  , UndecidableInstances+  , InstanceSigs+  , LambdaCase+ #-}++module MyMaybeT (MaybeT(..)) where++import Control.Monad.Trans.Class+import Control.Applicative+import Control.Monad.State++newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }++instance Functor m => Functor (MaybeT m) where+  fmap :: (a -> b) -> MaybeT m a -> MaybeT m b+  fmap f (MaybeT mma) = MaybeT (fmap (fmap f) mma)++instance Applicative m => Applicative (MaybeT m) where+  pure :: a -> MaybeT m a+  pure a = MaybeT (pure $ Just a)++  (<*>) :: MaybeT m (a -> b) -> MaybeT m a -> MaybeT m b+  (MaybeT mf) <*> (MaybeT mx) = MaybeT ((<*>) <$> mf <*> mx)++{-+instance Monad m => Monad (MaybeT m) where+  (>>=) :: MaybeT m a -> (a -> MaybeT m b) -> MaybeT m b+  (MaybeT mx) >>= f = MaybeT $ do+    v <- mx+    case v of+      Nothing -> pure Nothing+      Just a -> runMaybeT (f a)+-}++instance Monad m => Monad (MaybeT m) where+  (>>=) :: MaybeT m a -> (a -> MaybeT m b) -> MaybeT m b+  (MaybeT ma) >>= f = +    MaybeT $+       ma >>=+         \case+            Nothing -> pure Nothing+            Just a -> runMaybeT (f a)++instance MonadTrans MaybeT where+  lift :: Monad m => m a -> MaybeT m a+  lift ma = MaybeT $+               fmap Just ma++instance MonadState s m => MonadState s (MaybeT m)  where+  state :: (s -> (a, s)) -> MaybeT m a+  state = lift . state++instance Applicative m => Alternative (MaybeT m) where+  empty :: MaybeT m a+  empty = MaybeT (pure empty)++  (<|>) :: MaybeT m a -> MaybeT m a -> MaybeT m a+  (MaybeT mx) <|> (MaybeT my) = MaybeT ((<|>) <$> mx <*> my)++{-+instance Monad m => MonadPlus (MaybeT m) where+    mzero = empty+    mplus = (<|>)+-}

@@ -0,0 +1,27 @@+import qualified EvalRPN as E+import qualified EvalRPN_trans as E1+import qualified EvalRPN_trans2 as E2++import Control.Monad (mapM_, when)+import Data.Maybe++rpns = ["42",+        "12 13 +",+        "2 3 3 * + 5 *",+        "1 1 2 + 2 2 1 2 + * + * 1 3 2 * + + +",+        "13 2 12 2 1 2 13 2 + + + + + + +",+        "1 2 132 22 1 22 0 2 * * * * * * *",+        "10 1 2 + 2 2 1 2 * + * * * 1 3 2 + + +"]++showEvalRes :: String -> String+showEvalRes e = e ++ " = " ++ maybe "ERROR" show (E1.evalRPN e) ++main = do+  print $ E.evalRPN "2 3 +"+  print $ E1.evalRPN "2 x +"+  print $ E2.evalRPN "x 3 +"+  let res1 = map E1.evalRPN rpns+  mapM_ (putStrLn . showEvalRes) rpns    +  let    res2 = map E2.evalRPN rpns+  when (res1 == res2) $ putStrLn "E2 OK"+

@@ -0,0 +1,51 @@+import Text.Show+import Control.Monad+import Data.Foldable+import Language.Haskell.Interpreter++data Expr a = Lit a | Add (Expr a) (Expr a) | Mult (Expr a) (Expr a)++instance Show a => Show (Expr a) where+  showsPrec _ (Lit a)  = shows a+  showsPrec p (Add e1 e2) = showParen (p > precAdd)+                            $ showsPrec precAdd e1+                              . showString "+" +                              . showsPrec precAdd e2+    where precAdd = 5+  showsPrec p (Mult e1 e2) = showParen (p > precMult)+                             $ showsPrec precMult e1+                               . showString "*"+                               . showsPrec precMult e2+    where precMult = 6++myeval :: Num a => Expr a -> a+myeval (Lit e) = e+myeval (Add e1 e2) = myeval e1 + myeval e2+myeval (Mult e1 e2) = myeval e1 * myeval e2++testexpr e = do+  let e_str = show e+      e_val = myeval e+  putStr $ e_str ++ " = " ++ show e_val ++ " "+  r <- runInterpreter $ setImports ["Prelude"] >> eval e_str+  case r of+    Right r' -> if read r' == e_val+                   then putStrLn "ok"+                   else putStrLn "eval error"     +    _ -> putStrLn "interpreter error"++main = traverse_ testexpr exprs++exprs = [+  Mult (Add (Lit 2) (Mult (Lit 3) (Lit 3))) (Lit 5),+  Add (Add (Lit 1) (Mult (Add (Lit 1) (Lit 2))+                           (Add (Lit 2) (Mult (Lit 2) (Add (Lit 1) (Lit 2))))))+      (Add (Lit 1) (Mult (Lit 3) (Lit 2))),+  Add (Add (Add (Lit 1) (Lit 2)) (Add (Lit 1) (Lit 2)))+      (Add (Add (Lit 1) (Lit 2)) (Add (Lit 1) (Lit 2))),+  Mult (Mult (Mult (Lit 1) (Lit 2)) (Mult (Lit 1) (Lit 2)))+       (Mult (Mult (Lit 1) (Lit 2)) (Mult (Lit 1) (Lit 2))),+  Add (Mult (Lit 1) (Mult (Add (Lit 1) (Lit 2))+                     (Mult (Lit 2) (Add (Lit 2) (Mult (Lit 1) (Lit 2))))))+      (Add (Lit 1) (Add (Lit 3) (Lit 2)))+         ]

@@ -0,0 +1,177 @@+import Data.Char+import Data.List+import Data.Foldable+import Control.Monad.State++-- Implementation of the Shunting-yard algorithm++data Expr a = Lit a | Add (Expr a) (Expr a) | Mult (Expr a) (Expr a)++type Token = String+type Stack = [Token]+type Output = [Expr Integer]+type MyState = (Stack, Output)++push :: Token -> State MyState ()+push t = modify (\(s, es) -> (t : s, es))++pop :: State MyState Token+pop = do+  (t : s, es) <- get -- let it crash on empty stack+  put (s, es)+  pure t++pop_ :: State MyState ()  -- let it crash on empty stack+pop_ = modify (\(s, es) -> (tail s, es))++top :: State MyState Token+top = gets (head . fst) -- let it crash on empty stack++isEmpty :: State MyState Bool+isEmpty = null <$> gets fst++notEmpty :: State MyState Bool+notEmpty = not <$> isEmpty++output :: Token -> State MyState ()+output t = modify (builder t <$>)+  where +    builder "+" (e1 : e2 : es) = Add e1 e2 : es+    builder "*" (e1 : e2 : es) = Mult e1 e2 : es+    builder n es = Lit (read n) : es -- let it crash on not a number++whileNotEmptyAnd :: (Token -> Bool) -> State MyState () -> State MyState ()+whileNotEmptyAnd pred m = go+  where+    go = do+      b1 <- notEmpty+      when b1 $ do+        b2 <- pred <$> top+        when b2 (m >> go)++isOp "+" = True+isOp "*" = True+isOp _ = False++precedence "+" = 1+precedence "*" = 2+precedence _ = 0++t1 `precGTE` t2 = precedence t1 >= precedence t2 ++convertToExpr :: String -> Expr Integer+convertToExpr str = head $ snd $ execState convert ([], [])+  where+    convert = traverse_ processToken (reverse $ tokenize str) >> transferRest++    processToken ")" = push ")"+    processToken "(" = transferWhile (/= ")") >> pop_+    processToken t+      | isOp t = transferWhile (`precGTE` t) >> push t+      | otherwise = output t -- number++    transfer = pop >>= output+    transferWhile pred = whileNotEmptyAnd pred transfer+    transferRest = transferWhile (const True)+    +    tokenize = groupBy (\a b -> isDigit a && isDigit b)+               . filter (not . isSpace)++{-++https://en.wikipedia.org/wiki/Shunting-yard_algorithm++* stack+* output+* reading tokens in reversed order++while there are tokens to be read:+  read a token.+  if the token is a right bracket (i.e. ")"), then:+    push it onto the stack.+  if the token is a left bracket (i.e. "("), then:+    while the operator at the top of the stack is not a right bracket:+      pop the operator from the stack onto the output.+    pop the right bracket from the stack.+    /* if the stack runs out without finding a right bracket,+       then there are mismatched parentheses. */+  if the token is an operator, then:+    while ((there is an operator at the top of the stack+                        with equal or greater precedence)+           and (the operator at the top of the stack+                is not a left bracket):+       pop operators from the stack onto the output.+    push it onto the stack.+  if the token is a number, then:+    push it to the output.++if there are no more tokens to read:+  while there are still operator tokens on the stack:+    /* if the operator token on the top of the stack is a bracket,+       then there are mismatched parentheses. */+    pop the operator from the operator stack onto the output.+exit.++-}++-- Printing `Expr a` values++instance Show a => Show (Expr a) where+  showsPrec _ (Lit a)  = shows a+  showsPrec p (Add e1 e2) = showParen (p > precAdd)+                            $ showsPrec precAdd e1+                              . showString "+" +                              . showsPrec precAdd e2+    where precAdd = 5+  showsPrec p (Mult e1 e2) = showParen (p > precMult)+                             $ showsPrec (precMult) e1+                               . showString "*"+                               . showsPrec (precMult) e2+    where precMult = 6++-- Evaluating expressions++myeval :: Num a => Expr a -> a+myeval (Lit e) = e+myeval (Add e1 e2) = myeval e1 + myeval e2+myeval (Mult e1 e2) = myeval e1 * myeval e2++-- Testing++strs = ["42", "12 + 13", "(2+3*3)*5", "1+(1+2)*(2+2*(1+2))+1+3*2",+        "13+2+12+2+1+2+13+2", "1*2*132*22*1*22*0*2", "10*(1+2)*2*(2+1*2)+1+3+2"]++view = traverse_ printExpr strs+  where+    printExpr s = do+      let e = convertToExpr s+      putStrLn $ show e ++ "=" ++ show (myeval e)++exprs = map convertToExpr strs+exprs' = map (convertToExpr . show) exprs++check = and $ zipWith (\e1 e2 -> myeval e1 == myeval e2) exprs exprs'++-- Converting expressions to prefix and postfix forms++data ExprForm = Prefix | Postfix++exprTo _ (Lit a) = show a+exprTo form (Add e1 e2) = binOp "+" form e1 e2+exprTo form (Mult e1 e2) = binOp "*" form e1 e2++binOp op form e1 e2 = concat $ intersperse " " (args form) +   where+     e1' = exprTo form e1+     e2' = exprTo form e2+     args Prefix = [op, e1', e2']+     args Postfix = [e1', e2', op]++main = do+  view+  putStr "Checked: "+  print check+  putStrLn "\nPrefix forms: "+  mapM_ (putStrLn.exprTo Prefix) exprs+  putStrLn "\nPostfix forms: "+  mapM_ (putStrLn.exprTo Postfix) exprs

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 6d9bc7f35a54450595b8cfc3a4fe434408d4bb09fdf34222dfa11b29c8a6861b+-- hash: 4c5a4f5427bcb54285ad846ee88355b7c5c537a0cb7f6501f6a5bb3d656b2f7c  name:           hid-examples-version:        0.2+version:        0.3 synopsis:       Examples to accompany the book "Haskell in Depth" description:    This package provides source code examples which accompany the book "Haskell in Depth" by Vitaly Bragilevsky (Manning Publications 2019). You may want to get this package via @cabal get hid-examples@ and explore its content. category:       Sample Code@@ -48,6 +48,26 @@     , random >=1.0 && <1.2   default-language: Haskell2010 +executable du+  main-is: du.hs+  other-modules:+      App+      AppRWS+      DiskUsage+      FileCount+      TraverseDir+      Paths_hid_examples+  hs-source-dirs:+      du+  build-depends:+      base >=4.10 && <4.12+    , directory >=1.3 && <1.4+    , filepath >=1.4.2 && <1.5+    , mtl >=2.0 && <2.3+    , optparse-applicative >=0.14 && <0.15+    , unix-compat >=0.5 && <0.6+  default-language: Haskell2010+ executable filecount   main-is: filecount.hs   other-modules:@@ -112,17 +132,34 @@     , mtl >=2.0 && <2.3   default-language: Haskell2010 +executable rpnexpr+  main-is: rpnexpr.hs+  other-modules:+      EvalRPN+      EvalRPN_trans+      EvalRPN_trans2+      MyMaybeT+      Paths_hid_examples+  hs-source-dirs:+      expr+  build-depends:+      base >=4.10 && <4.12+    , mtl >=2.0 && <2.3+    , safe >=0.3 && <0.4+    , transformers >=0.5 && <0.6+  default-language: Haskell2010+ executable showexpr-  main-is: showexpr.hs+  main-is: expr/showexpr.hs   other-modules:       Paths_hid_examples   build-depends:       base >=4.10 && <4.12-    , hint >=0.7 && <0.9+    , hint >=0.7 && <0.10   default-language: Haskell2010  executable shunting-yard-  main-is: shunting-yard.hs+  main-is: expr/shunting-yard.hs   other-modules:       Paths_hid_examples   build-depends:

@@ -1,5 +1,5 @@ name: hid-examples-version: 0.2+version: 0.3 synopsis: Examples to accompany the book "Haskell in Depth" description:         This package provides source code examples which accompany the book@@ -41,8 +41,8 @@         main: vocab3.hs         dependencies: text >=1.2 && <1.3     showexpr:-        main: showexpr.hs-        dependencies: hint >=0.7 && <0.9+        main: expr/showexpr.hs+        dependencies: hint >=0.7 && <0.10     # Chapter 3     stockquotes:         source-dirs: stockquotes@@ -93,7 +93,7 @@           - mtl >=2.0 && <2.3           - random >=1.0 && <1.2     shunting-yard:-        main: shunting-yard.hs+        main: expr/shunting-yard.hs         dependencies:           - mtl >=2.0 && <2.3     dicegame:@@ -109,3 +109,20 @@           - extra >=1.5 && <1.7     stref:         main: stref.hs+    # Chapter 6+    du:+        source-dirs: du+        main: du.hs+        dependencies:+          - mtl >=2.0 && <2.3+          - filepath >= 1.4.2 && < 1.5+          - directory >= 1.3 && < 1.4+          - unix-compat >= 0.5 && < 0.6+          - optparse-applicative >= 0.14 && < 0.15+    rpnexpr:+        source-dirs: expr+        main: rpnexpr.hs+        dependencies:+          - mtl >= 2.0 && < 2.3+          - transformers >= 0.5 && < 0.6+          - safe >=0.3 && <0.4

@@ -1,51 +0,0 @@-import Text.Show-import Control.Monad-import Data.Foldable-import Language.Haskell.Interpreter--data Expr a = Lit a | Add (Expr a) (Expr a) | Mult (Expr a) (Expr a)--instance Show a => Show (Expr a) where-  showsPrec _ (Lit a)  = shows a-  showsPrec p (Add e1 e2) = showParen (p > precAdd)-                            $ showsPrec precAdd e1-                              . showString "+" -                              . showsPrec precAdd e2-    where precAdd = 5-  showsPrec p (Mult e1 e2) = showParen (p > precMult)-                             $ showsPrec precMult e1-                               . showString "*"-                               . showsPrec precMult e2-    where precMult = 6--myeval :: Num a => Expr a -> a-myeval (Lit e) = e-myeval (Add e1 e2) = myeval e1 + myeval e2-myeval (Mult e1 e2) = myeval e1 * myeval e2--testexpr e = do-  let e_str = show e-      e_val = myeval e-  putStr $ e_str ++ " = " ++ show e_val ++ " "-  r <- runInterpreter $ setImports ["Prelude"] >> eval e_str-  case r of-    Right r' -> if read r' == e_val-                   then putStrLn "ok"-                   else putStrLn "eval error"     -    _ -> putStrLn "interpreter error"--main = traverse_ testexpr exprs--exprs = [-  Mult (Add (Lit 2) (Mult (Lit 3) (Lit 3))) (Lit 5),-  Add (Add (Lit 1) (Mult (Add (Lit 1) (Lit 2))-                           (Add (Lit 2) (Mult (Lit 2) (Add (Lit 1) (Lit 2))))))-      (Add (Lit 1) (Mult (Lit 3) (Lit 2))),-  Add (Add (Add (Lit 1) (Lit 2)) (Add (Lit 1) (Lit 2)))-      (Add (Add (Lit 1) (Lit 2)) (Add (Lit 1) (Lit 2))),-  Mult (Mult (Mult (Lit 1) (Lit 2)) (Mult (Lit 1) (Lit 2)))-       (Mult (Mult (Lit 1) (Lit 2)) (Mult (Lit 1) (Lit 2))),-  Add (Mult (Lit 1) (Mult (Add (Lit 1) (Lit 2))-                     (Mult (Lit 2) (Add (Lit 2) (Mult (Lit 1) (Lit 2))))))-      (Add (Lit 1) (Add (Lit 3) (Lit 2)))-         ]

@@ -1,177 +0,0 @@-import Data.Char-import Data.List-import Data.Foldable-import Control.Monad.State---- Implementation of the Shunting-yard algorithm--data Expr a = Lit a | Add (Expr a) (Expr a) | Mult (Expr a) (Expr a)--type Token = String-type Stack = [Token]-type Output = [Expr Integer]-type MyState = (Stack, Output)--push :: Token -> State MyState ()-push t = modify (\(s, es) -> (t : s, es))--pop :: State MyState Token-pop = do-  (t : s, es) <- get -- let it crash on empty stack-  put (s, es)-  pure t--pop_ :: State MyState ()  -- let it crash on empty stack-pop_ = modify (\(s, es) -> (tail s, es))--top :: State MyState Token-top = gets (head . fst) -- let it crash on empty stack--isEmpty :: State MyState Bool-isEmpty = null <$> gets fst--notEmpty :: State MyState Bool-notEmpty = not <$> isEmpty--output :: Token -> State MyState ()-output t = modify (builder t <$>)-  where -    builder "+" (e1 : e2 : es) = Add e1 e2 : es-    builder "*" (e1 : e2 : es) = Mult e1 e2 : es-    builder n es = Lit (read n) : es -- let it crash on not a number--whileNotEmptyAnd :: (Token -> Bool) -> State MyState () -> State MyState ()-whileNotEmptyAnd pred m = go-  where-    go = do-      b1 <- notEmpty-      when b1 $ do-        b2 <- pred <$> top-        when b2 (m >> go)--isOp "+" = True-isOp "*" = True-isOp _ = False--precedence "+" = 1-precedence "*" = 2-precedence _ = 0--t1 `precGTE` t2 = precedence t1 >= precedence t2 --convertToExpr :: String -> Expr Integer-convertToExpr str = head $ snd $ execState convert ([], [])-  where-    convert = traverse_ processToken (reverse $ tokenize str) >> transferRest--    processToken ")" = push ")"-    processToken "(" = transferWhile (/= ")") >> pop_-    processToken t-      | isOp t = transferWhile (`precGTE` t) >> push t-      | otherwise = output t -- number--    transfer = pop >>= output-    transferWhile pred = whileNotEmptyAnd pred transfer-    transferRest = transferWhile (const True)-    -    tokenize = groupBy (\a b -> isDigit a && isDigit b)-               . filter (not . isSpace)--{---https://en.wikipedia.org/wiki/Shunting-yard_algorithm--* stack-* output-* reading tokens in reversed order--while there are tokens to be read:-  read a token.-  if the token is a right bracket (i.e. ")"), then:-    push it onto the stack.-  if the token is a left bracket (i.e. "("), then:-    while the operator at the top of the stack is not a right bracket:-      pop the operator from the stack onto the output.-    pop the right bracket from the stack.-    /* if the stack runs out without finding a right bracket,-       then there are mismatched parentheses. */-  if the token is an operator, then:-    while ((there is an operator at the top of the stack-                        with equal or greater precedence)-           and (the operator at the top of the stack-                is not a left bracket):-       pop operators from the stack onto the output.-    push it onto the stack.-  if the token is a number, then:-    push it to the output.--if there are no more tokens to read:-  while there are still operator tokens on the stack:-    /* if the operator token on the top of the stack is a bracket,-       then there are mismatched parentheses. */-    pop the operator from the operator stack onto the output.-exit.---}---- Printing `Expr a` values--instance Show a => Show (Expr a) where-  showsPrec _ (Lit a)  = shows a-  showsPrec p (Add e1 e2) = showParen (p > precAdd)-                            $ showsPrec precAdd e1-                              . showString "+" -                              . showsPrec precAdd e2-    where precAdd = 5-  showsPrec p (Mult e1 e2) = showParen (p > precMult)-                             $ showsPrec (precMult) e1-                               . showString "*"-                               . showsPrec (precMult) e2-    where precMult = 6---- Evaluating expressions--myeval :: Num a => Expr a -> a-myeval (Lit e) = e-myeval (Add e1 e2) = myeval e1 + myeval e2-myeval (Mult e1 e2) = myeval e1 * myeval e2---- Testing--strs = ["42", "12 + 13", "(2+3*3)*5", "1+(1+2)*(2+2*(1+2))+1+3*2",-        "13+2+12+2+1+2+13+2", "1*2*132*22*1*22*0*2", "10*(1+2)*2*(2+1*2)+1+3+2"]--view = traverse_ printExpr strs-  where-    printExpr s = do-      let e = convertToExpr s-      putStrLn $ show e ++ "=" ++ show (myeval e)--exprs = map convertToExpr strs-exprs' = map (convertToExpr . show) exprs--check = and $ zipWith (\e1 e2 -> myeval e1 == myeval e2) exprs exprs'---- Converting expressions to prefix and postfix forms--data ExprForm = Prefix | Postfix--exprTo _ (Lit a) = show a-exprTo form (Add e1 e2) = binOp "+" form e1 e2-exprTo form (Mult e1 e2) = binOp "*" form e1 e2--binOp op form e1 e2 = concat $ intersperse " " (args form) -   where-     e1' = exprTo form e1-     e2' = exprTo form e2-     args Prefix = [op, e1', e2']-     args Postfix = [e1', e2', op]--main = do-  view-  putStr "Checked: "-  print check-  putStrLn "\nPrefix forms: "-  mapM_ (putStrLn.exprTo Prefix) exprs-  putStrLn "\nPostfix forms: "-  mapM_ (putStrLn.exprTo Postfix) exprs

@@ -2,3 +2,6 @@  packages: - .++extra-deps:+- filepath-1.4.2.1