Assignment 3

{-# LANGUAGE FlexibleContexts #-}
module A03 where

import Control.Monad.Writer
import Data.Char
import GHC.Stack
import System.Exit

-- The idea of "splitFirst" is that it takes a list and returns a pair
-- of lists. The first list is a singleton containing the first element
-- of the parameter. The second list is all the remaining elements.
-- (But if the original list is empty, both returned lists are empty.)
-- Concatenating the pair should always produce the original list; that
-- is, if splitFirst xs == (as, bs) then xs == as ++ bs.

-- Try to write THREE different versions of the function, that all have
-- the same behavior. I used take/drop for V1, splitAt for V2, and
-- head/tail for V3, but yours can be different.

splitFirstV1 :: [a] -> ([a], [a])
splitFirstV1 xs = (xs, xs)

splitFirstV2 :: [a] -> ([a], [a])
splitFirstV2 xs = (xs, xs)

splitFirstV3 :: [a] -> ([a], [a])
splitFirstV3 xs = (xs, xs)

------------------------------------------------------------------

-- Similarly, "splitLast" returns a pair of lists, where the first list
-- contains all the elements UP TO the last one, and the second list is
-- a singleton containing the last element. Again, it should just
-- produce empty lists when the original is empty, and concatenating
-- the pair should always produce the original list.

-- Try three versions of this as well. I used splitAt for V1, init/last
-- for V2, and reverse along with splitFirst (any version) for V3!

splitLastV1 :: [a] -> ([a], [a])
splitLastV1 xs = (xs, xs)

splitLastV2 :: [a] -> ([a], [a])
splitLastV2 xs = (xs, xs)

splitLastV3 :: [a] -> ([a], [a])
splitLastV3 xs = (xs, xs)

------------------------------------------------------------------

-- Now, use (any version of) splitFirst and splitLast to create
-- splitFirstLast, that returns a tuple of three lists.

splitFirstLast :: [a] -> ([a], [a], [a])
splitFirstLast xs = (xs, xs, xs)

-- This should produce the same behavior as dropFirstLast in assignment
-- two, but implement it using splitFirstLast.

dropFirstLast :: [a] -> [a]
dropFirstLast xs = xs

-- This should produce the same behavior as numeronym in assignment
-- two, but implement it using splitFirstLast.

numeronym :: String -> String
numeronym xs = xs

------------------------------------------------------------------
-- Test program -- don't change anything below

main = runTests $ do
  -- Test all splitFirst versions
  forM_ (zip [1..] [splitFirstV1, splitFirstV2, splitFirstV3]) $ \(n,f) -> do
    lift . putStrLn $ "~~~~ splitFirstV" ++ show n ++ " ~~~~"
    f "abc" @?= ("a", "bc")
    f "ab" @?= ("a", "b")
    f "a" @?= ("a", "")
    f "" @?= ("", "")

  -- Test all splitLast versions
  forM_ (zip [1..] [splitLastV1, splitLastV2, splitLastV3]) $ \(n,f) -> do
    lift . putStrLn $ "~~~~ splitLastV" ++ show n ++ " ~~~~"
    f "abc" @?= ("ab", "c")
    f "ab" @?= ("a", "b")
    f "a" @?= ("", "a")
    f "" @?= ("", "")

  lift $ putStrLn "~~ splitFirstLast ~~"
  splitFirstLast "travel" @?= ("t", "rave", "l")
  splitFirstLast [1..5] @?= ([1], [2,3,4], [5])
  splitFirstLast "XY" @?= ("X", "", "Y")
  splitFirstLast "Z" @?= ("Z", "", "")
  splitFirstLast "" @?= ("", "", "")

  lift $ putStrLn "~~ dropFirstLast ~~"
  dropFirstLast "travel" @?= "rave"
  dropFirstLast [1..5] @?= [2,3,4]
  dropFirstLast "XY" @?= ""
  dropFirstLast "Z" @?= ""
  dropFirstLast "" @?= ""

  lift $ putStrLn "~~ numeronym ~~"
  numeronym "internationalization" @?= "i18n"
  numeronym "accessibility" @?= "a11y"
  numeronym "crowded" @?= "c5d"
  numeronym "Ten" @?= "T1n"
  numeronym "so" @?= "so"
  numeronym "x" @?= "x"
  numeronym "" @?= ""

-- Test framework -- don't change anything below

infix  1 @?~, @?=

type TestM = WriterT (Sum Int) IO

runTests :: TestM () -> IO ()
runTests tests = do
  numFails <- getSum <$> execWriterT tests
  when (numFails > 0) $ exitWith (ExitFailure numFails)

(@?~) :: (HasCallStack, Fractional a, Ord a, Show a)
  => a -> a -> TestM ()
(@?~) a1 a2 =
  testBinRel callStack "~="
  (\a b -> abs (a-b) <= 0.00001) a1 a2

(@?=) :: (HasCallStack, Eq a, Show a) => a -> a -> TestM ()
(@?=) a1 a2 =
  testBinRel callStack "==" (==) a1 a2

assertTrue :: HasCallStack => Bool -> TestM ()
assertTrue expr =
  testReport callStack expr "expected true"

assertFalse :: HasCallStack => Bool -> TestM ()
assertFalse expr =
  testReport callStack (not expr) "expected false"

testBinRel stack repr predicate a1 a2 =
  testReport stack (predicate a1 a2)
  (unwords [show a1, repr, show a2])

testReport stack pass descr = do
  unless pass (tell (Sum 1))
  lift . putStrLn $ unwords
    [ if pass then " OK " else "FAIL"
    , "line"
    , getLineNum stack
    , ":"
    , descr
    ]

getLineNum stack =
  case getCallStack stack of
    [] -> "?"
    (_, loc):_ -> show (srcLocStartLine loc)