Real World Haskell Exercises

page_205_exercises.hs

module GlobRegex
       (
        globToRegex,
        matchesGlob
       )
where
  
  import Text.Regex.Posix ((=~))
  import Data.Char (toLower)
  
  globToRegex :: String -> String
  globToRegex cs = '^' : globToRegex' cs ++ "$"
  
  globToRegex' :: String -> String
  globToRegex' "" = ""
  globToRegex' ('*':cs) = ".*" ++ globToRegex' cs
  globToRegex' ('?':cs) = '.' : globToRegex' cs
  globToRegex' ('[':'!':c:cs) = "[^" ++ (c : charClass cs)
  globToRegex' ('[':c:cs) = '[': c : charClass cs
  globToRegex' ('[':_) = error "unterminated character class"
  globToRegex' (c:cs) = escape c ++ globToRegex' cs
  
  escape :: Char -> String
  escape c | c `elem` regexChars = '\\' : [c]
           | otherwise = [c]
    where
      regexChars = "\\+()^$.{}]|"
  
  charClass :: String -> String
  charClass (']':cs) = ']' : globToRegex' cs
  charClass (c:cs) = c : charClass cs
  charClass [] = error "unterminated character class"
  
  matchesGlob :: FilePath -> String -> Bool
  name `matchesGlob` glob = name =~ (globToRegex glob)

  {-- 
  Exercise 2.
  While filesystems on Unix are usually sensitive to case (e.g. “G” vs. “g”) in file names, Windows filesystems are not. Add a parameter to the globToRegex and matchesGlob functions that allows control over case sensitive matching.
  --}

  globToRegex2 :: String -> Bool -> String
  globToRegex2 str False = globToRegex $ map toLower str
  globToRegex2 str True  = globToRegex str

  matchesGlob2 :: FilePath -> String -> Bool -> Bool
  matchesGlob2 name glob False = (map toLower name) =~ (globToRegex2 glob True)
  matchesGlob2 name glob True  = name =~ (globToRegex2 glob False)
  

page_210_exercise_3_a.hs

module Glob (namesMatching) where
  
  import System.FilePath (dropTrailingPathSeparator, splitFileName, 
                          searchPathSeparator, (</>))
  import Control.OldException (handle)
  import Data.List (isInfixOf, isPrefixOf)
  import Control.Monad (forM)
  import GlobRegex (windowsGlob, unixGlob)
  import System.Directory (doesDirectoryExist, doesFileExist,
                           getCurrentDirectory, getDirectoryContents)
  import GreedyGlob (isGreedyGlob, getSubdirectoryTree)
  
  
  
  isPattern :: String -> Bool
  isPattern = any (`elem` "[*?")
  
  
  processGreedyNamesMatching :: String -> String -> IO [FilePath]
  processGreedyNamesMatching currentDir pat = do
    let pattern = drop 1 pat
    let patlength = (length currentDir) + 1
    
    dirs <- getSubdirectoryTree currentDir
    let dirs' = map (drop patlength) dirs
    
    listDir <- forM (dirs') $ \dir -> do
                 baseNames <- listMatches dir pattern
                 return (map (dir </>) baseNames)
    
    currentDirList <- listMatches currentDir pattern
    
    return (concat (currentDirList:listDir))
  
  namesMatching :: String -> IO [FilePath]
  namesMatching pat
    | not (isPattern pat) = do exists <- doesNameExist pat
                               return (if exists then [pat] else [])
    | otherwise = do
        case splitFileName pat of 
            ("", baseName) -> do
              currentDir <- getCurrentDirectory
              
              if isGreedyGlob pat
                then processGreedyNamesMatching currentDir baseName
                else listMatches currentDir baseName
            
            (dirName, baseName) -> do
              dirs <- if isPattern dirName
                        then namesMatching (dropTrailingPathSeparator dirName)
                        else return [dirName]
              
              let listDir = if isPattern dirName
                              then listMatches
                              else listPlain
              
              pathNames <- forM dirs $ \dir -> do
                             baseNames <- listDir dir baseName
                             return (map (dir </>) baseNames)
              
              return (concat pathNames)
  
  doesNameExist :: FilePath -> IO Bool
  doesNameExist name = do
    fileExist <- doesFileExist name
    if fileExist
      then return True
      else doesDirectoryExist name
  
  listMatches :: FilePath -> String -> IO [String]
  listMatches dirName pat = do
    dirName' <- if null dirName
                  then getCurrentDirectory
                  else return dirName
    
    handle (const (return [])) $ do
      names <- getDirectoryContents dirName'
      let matchesGlob = if isWindows
                      then (`windowsGlob` pat)
                      else (`unixGlob` pat)
      
      let names' = if isHidden pat
                    then filter isHidden names
                    else filter (not . isHidden) names
      
      return (filter matchesGlob names')

  isHidden :: String -> Bool
  isHidden ('.':_) = True
  isHidden _       = False
  
  listPlain :: FilePath -> String -> IO [String]
  listPlain dirName baseName = do
    exists <- if null baseName
                then doesDirectoryExist dirName
                else doesNameExist (dirName </> baseName)
    return (if exists then [baseName] else [])
    
  isWindows :: Bool
  isWindows = searchPathSeparator == ';'

page_210_exercise_3_b.hs

module GreedyGlob where
  
  import Data.List
  import Control.Monad
  import System.Directory
  import System.FilePath
  
  
  isGreedyGlob :: String -> Bool
  isGreedyGlob path = 
    if (isInfixOf "**" dirName)
      then error "Invalid Glob"
      else (isPrefixOf "**" baseName)
    where
      (dirName, baseName) = splitFileName path
    
  getSubdirectories :: FilePath -> IO [FilePath]
  getSubdirectories dirPath = do
    contents <- getDirectoryContents dirPath
    let contents' = map (dirPath </>) $ filter (\x -> x /= "." && x /= "..") contents
    filterM doesDirectoryExist contents'

  getSubdirectoryTree :: FilePath -> IO [FilePath]
  getSubdirectoryTree currentDir = do
    dirs <- getSubdirectories currentDir
    subdirs <- forM dirs $ \dir -> do
      sub <- getSubdirectoryTree dir
      return sub
    return $ dirs ++ (concat subdirs)

  

page_228_exercises_better_predicate.hs

module BetterPredicate where 
  
  import System.IO (IOMode(..), hFileSize, hClose, openFile)
  import System.Directory (Permissions(..), getPermissions, getModificationTime)
  import Control.OldException (handle, bracket)
  import Control.Monad (filterM)
  import System.Time (ClockTime(..))
  import System.FilePath (takeExtension)
  import RecursiveContents (getRecursiveContents)
  
  
  type InfoP a = FilePath -> Permissions -> Maybe Integer -> ClockTime -> a
  
  getFileSize :: FilePath -> IO (Maybe Integer)
  getFileSize file = handle (\_ -> return Nothing) $ 
    bracket (openFile file ReadMode) hClose $ \h -> do
      size <- hFileSize h
      return (Just size)

  betterFind :: InfoP Bool -> FilePath -> IO [FilePath]
  betterFind p topdir = getRecursiveContents topdir >>= filterM check
    where 
      check name = do
        perms <- getPermissions name
        size  <- getFileSize name
        modified <- getModificationTime name
        return (p name perms size modified)

  pathP :: InfoP FilePath
  pathP name _ _ _ = name
  
  sizeP :: InfoP Integer
  sizeP _ _ (Just size) _ = size
  sizeP _ _ (Nothing) _ = -1
  
  oldEqualP :: (Eq a) => InfoP a -> a -> InfoP Bool
  oldEqualP f k = \path perm size time -> f path perm size time == k

  liftP :: (a -> b -> c) -> InfoP a -> b -> InfoP c
  liftP q f k = \path perm size time -> f path perm size time `q` k
  
  equalP :: (Eq a) => InfoP a -> a -> InfoP Bool
  equalP   = liftP (==)
  
  greaterP, lesserP :: (Ord a) => InfoP a -> a -> InfoP Bool
  lesserP  = liftP (<)
  greaterP = liftP (>)
  
  simpleAndP :: InfoP Bool -> InfoP Bool -> InfoP Bool
  simpleAndP f g = \path perm size time -> (f path perm size time) && (g path perm size time)
  
  liftP2 :: (a -> b -> c) -> InfoP a -> InfoP b -> InfoP c
  liftP2 q f g = \path perm size time -> (f path perm size time) `q` (g path perm size time)
  
  andP = liftP2 (&&)
  orP  = liftP2 (||)
  
  (==?) = equalP
  (&&?) = andP
  (||?) = orP
  -- (>?)  = greaterP
  
  liftPath :: (FilePath -> String) -> InfoP String
  liftPath f = \path perm size time -> f path
  
  haskellFiles = (liftPath takeExtension ==? ".hs") -- &&? (sizeP >? 131072)
  

page_228_exercises_controlled_visit.hs

module ControlledVisit where
  
  import Data.Ord (comparing)
  import Data.List (sortBy)
  import System.Time (ClockTime(..))
  import System.IO (IOMode(..), hClose, hFileSize, openFile)
  import System.Directory (Permissions(..), getDirectoryContents, getPermissions, getModificationTime)
  import System.FilePath ((</>), splitFileName)
  import Control.Monad (forM, mapM, liftM, filterM, mapM_)
  import Control.OldException (handle, bracket)
  import BetterPredicate
  
  
  data Info = MkInfo {
    infoPath    :: FilePath,
    infoPerms   :: Maybe Permissions,
    infoSize    :: Maybe Integer,
    infoModTime :: Maybe ClockTime
  } deriving (Eq, Ord, Show)
  
  traverse :: ([Info] -> [Info]) -> FilePath -> IO [Info]
  traverse order path = do
    names <- getUsefulContents path
    contents <- mapM getInfo (path : map (path </>) names)
    liftM concat $ forM (order contents) $ \info -> do
      if isDirectory info && infoPath info /= path
        then traverse order (infoPath info)
        else return [info]
  
  
  getUsefulContents :: FilePath -> IO [FilePath]
  getUsefulContents path = do 
    names <- getDirectoryContents path
    return (filter (`notElem` [".", ".."]) names)
    
  isDirectory :: Info -> Bool
  isDirectory = maybe False searchable . infoPerms
  
  maybeIO :: IO a -> IO (Maybe a)
  maybeIO act = handle (\_ -> return Nothing) (liftM Just act)
  
  getInfo :: FilePath -> IO Info
  getInfo path = do
    perms <- maybeIO (getPermissions path)
    size  <- maybeIO (bracket (openFile path ReadMode) hClose hFileSize)
    mtime <- maybeIO (getModificationTime path)
    return (MkInfo path perms size mtime)
    
  -- Exercise 1)
  -- What should you pass to traverse  to traverse a directory tree in reverse alphabetic order?
  reverseAlphabeticOrder :: [Info] -> [Info]
  reverseAlphabeticOrder = reverse . sortBy (comparing infoPath)
  
  traverseOnReverseAlphabeticOrder = traverse reverseAlphabeticOrder "."
  
  -- Exercise 2)
  -- Using id as a control function, traverse id performs a preorder traversal of a tree: it returns a 
  -- parent directory before its children. Write a control function that makes traverse  perform a 
  -- postorder traversal, in which it returns children before their parent
  
  postOrder :: [Info] -> [Info]
  postOrder infos = tail infos ++ [head infos]
  
  traverseInPostOrder = traverse postOrder "."
  
  -- Exercise 3, 4)
  -- Take the predicates and combinators from the section called “Gluing predicates together” 
  -- and make them work with our new Info type.
  
  info2infoP :: InfoP a -> Info -> a
  info2infoP f (MkInfo path (Just perm) size (Just time)) = f path perm size time
  
  filterFind :: InfoP Bool -> [Info] -> [Info]
  filterFind f = filter (info2infoP f)
  
  traverseAndFilter :: ([Info] -> [Info]) -> (InfoP Bool) -> FilePath -> IO [Info]
  traverseAndFilter f p directory = liftM (filterFind p) (traverse f directory)
  
  printResults :: IO [Info] -> IO ()
  printResults infos = do
    paths <- liftM (map infoPath) infos
    mapM_ (putStrLn) paths
  
  -- printResults (traverseAndFilter reverseAlphabeticOrder haskellFiles "."  )

page_228_exercises_recursive_contents.hs

module RecursiveContents (getRecursiveContents) where
  
  import System.FilePath ((</>))
  import System.Directory (getDirectoryContents, doesDirectoryExist)
  import Control.Monad (forM)
  
  getRecursiveContents :: FilePath -> IO [FilePath]
  getRecursiveContents topdir = do
    names <- getDirectoryContents topdir
    let properNames = filter (`notElem` [".", ".."]) names
    paths <- forM properNames $ \name -> do
               let path = topdir </> name
               isDirectory <- doesDirectoryExist path
               if isDirectory
                 then getRecursiveContents path
                 else return [path]
    return (concat paths)
                 

page_70_exercise_13.hs

import Data.List
import Data.Ord (comparing)

data Point = Point Double Double
           deriving (Show, Eq)
           
data Direction = ST
               | TL
               | TR
               deriving (Show, Eq)

xval :: Point -> Double
xval (Point x _) = x

yval :: Point -> Double
yval (Point _ y) = y

direction_of :: Point -> Point -> Point -> Direction
direction_of (Point x1 y1) (Point x2 y2) (Point x3 y3)
  | crossProduct == 0 = ST
  | crossProduct > 0  = TL
  | crossProduct < 0  = TR
  where
    crossProduct = (x2 - x1) * (y3 - y1) - (y2 - y1) * (x3 - x1)


tuple2point :: (Double, Double) -> Point
tuple2point (x, y) = Point x y

take_while_y_is_equal :: [Point] -> [Point]
take_while_y_is_equal (p:points) = p : takeWhile ( (==EQ) . comparing yval p) points

pivot_of :: [Point] -> Point
pivot_of =  head . sortBy (comparing xval) . take_while_y_is_equal . sortBy (comparing yval)

sort_by_angle :: [Point] -> [Point]
sort_by_angle points = pivot : sortBy (comparing angle) points_without_pivot
  where 
    pivot = pivot_of points
    points_without_pivot = delete pivot points
    angle p = atan2 (yval p - yval pivot) (xval p - xval pivot)

graham :: [Point] -> [Point]
graham ps = scan (reverse (take 3 points)) (drop 3 points)
  where
    points = sort_by_angle ps

scan :: [Point] -> [Point] -> [Point]
scan all_stack@(p2:p1:stack) all_ps@(p:ps)
  | direction_of p1 p2 p == TR  = scan (p1:stack) all_ps
  | otherwise                   = scan (p:all_stack) ps 

scan stack [] = stack

page_84_exercise_3.hs

import System.Environment (getArgs)

-- fx :: String -> String
-- It parses the file input and returns an string for the output
interactWith fx inputFile outputFile = do
  input <- readFile inputFile
  writeFile outputFile (fx input)

main = mainWith firstWordOfEachLine
  where 
    mainWith fx = do
      args <- getArgs
      case args of
        [input, output] -> interactWith fx input output
        _               -> putStrLn "error: exactly two arguments needed"

splitLines :: String -> [String]
splitLines [] = []
splitLines cs =
  let (pre, suf) = break isLineTerminator cs
  in pre : case suf of
            ('\r':'\n':rest) -> splitLines rest
            ('\n':rest)      -> splitLines rest
            _                -> []

isLineTerminator :: Char -> Bool
isLineTerminator c = c == '\r' || c == '\n'

safeHead :: [a] -> Maybe a
safeHead []    = Nothing
safeHead (x:_) = Just x

firstWordOfEachLine :: String -> String
firstWordOfEachLine = unlines . map ( (maybe [] id) . safeHead . words) . splitLines

page_84_exercise_4.hs

import System.Environment (getArgs)

-- fx :: String -> String
-- It parses the file input and returns an string for the output
interactWith fx inputFile outputFile = do
  input <- readFile inputFile
  writeFile outputFile (fx input)

main = mainWith transponseText
  where 
    mainWith fx = do
      args <- getArgs
      case args of
        [input, output] -> interactWith fx input output
        _               -> putStrLn "error: exactly two arguments needed"

splitLines :: String -> [String]
splitLines [] = []
splitLines cs =
  let (pre, suf) = break isLineTerminator cs
  in pre : case suf of
            ('\r':'\n':rest) -> splitLines rest
            ('\n':rest)      -> splitLines rest
            _                -> []

isLineTerminator :: Char -> Bool
isLineTerminator c = c == '\r' || c == '\n'

transponseWords :: [String] -> [String]
transponseWords ls = heads : if all (null) tails 
                             then []
                             else transponseWords tails
  where
    splitedLines = map (splitAt 1) ls 
    heads = concat $ map fst splitedLines
    tails = map snd splitedLines


transponseText :: String -> String
transponseText =  unlines . transponseWords . splitLines

 

page_97_exercises.hs

import Data.Char (digitToInt, isAlpha, isSpace)

-- 1, 2, 3)
asInt :: String -> Int
asInt []     = 0
asInt ['-']  = 0
asInt number = 
  case number of
    ('-':number) -> -1 * foldr step 0 (reverse number)
    number       -> foldr step 0 (reverse number)
  where
    step char accum = digitToInt(char) + 10 * accum

-- 4)
safeAsInt :: String -> Maybe Int
safeAsInt []    = Just 0
safeAsInt ['-'] = Just 0
safeAsInt number =
  case number of 
    ('-':number) -> Just (-1 * foldr step 0 (reverse number))
    all_number@(d:number) -> if isAlpha(d)
                             then Nothing
                             else Just (foldr step 0 (reverse all_number))
  where
   step char accum = digitToInt(char) + 10 * accum

-- 5, 6)
toggle :: (a -> b -> c) -> b -> a -> c
toggle f y x = f x y

myConcat :: [[a]] -> [a]
myConcat = foldr (toggle (foldr (:))) []

-- 7)
myRecursiveTakeWhile _ [] = []
myRecursiveTakeWhile p (x:xs) 
  | p x =  x : myRecursiveTakeWhile p xs
  | otherwise = []

myTakeWhile p = reverse . snd . foldr step (True, []) . reverse
  where
    step x (continue, acc) 
      | p x && continue = (True, x : acc)
      | otherwise       = (False, acc)


-- 8, 9)
myGroupBy :: (a -> a -> Bool) -> [a] -> [[a]]
myGroupBy eq = appendLast . foldr step ([], []) 
  where
    step x (current, total)
      | null current || eq x (head current) = (x:current, total)
      | otherwise                           = ([x], current:total)
    appendLast (current, total) = (current:total)

-- 10)
myAny :: (a -> Bool) -> [a] -> Bool
myAny p = foldr step False
  where
    step x acc = (p x) || acc
    
-- myCicle doesn't have a base case, is infinite!

myWords :: String -> [String]
myWords = appendLast . foldr step ([], [])
  where
    step x (word, acc)
      | isSpace x = ([], word:acc)
      | otherwise = (x:word, acc)
    appendLast (lastWord, allWords) = (lastWord:allWords)

myUnlines :: [String] -> String
myUnlines ls = foldr (toggle (foldr (:))) (last ls) (map (++"\n") (init ls))