Anyway, the servers are running in Docker containers on a VPS. Even though they are relatively small and handle simple things like basic auth, user accounts, simple business logic, etc., code updates can cause Docker rebuilbs to be painfully slow, even with caching. A fresh build takes up to 40 minutes. A cached build can be 10 to 30 minutes depending on how deep the change is.
I came across this comment on Hacker News and started thinking about testing other ecosystems. I have used a bit of Rust in the past so I decided to migrate one server from Haskell servant to Rust axum. The main concern was keeping code high quality so I used Rust’s linter, Clippy, and ported over all the unit tests I had in Haskell to Rust. I also used Docker to build the project. Currently a fresh build is about 15 minutes as opposed to Haskell’s 40 minutes. I did have to give up some type safety, but for small servers with relatively simple business logic, it is not a huge loss.
I will launch the service this week. I’ll report back in a month or so on my experiences in production.
]]>For much of my work with Haskell, I’ve used the ReaderT Design Pattern to pass around configs, mutable references, database connections, etc. to different parts of the executable. It’s a nice, simple pattern and good for smaller executables. It is still something I will use, but for larger projects, it is nice to have stricter control over what can happen in certain functions and encode that in the types.
That’s where the effects come in. The idea is to encode the effects in a function’s type signature and allow it to perform actions like reading or writing a file. effectful is a nice Haskell library for effects. The author has written a document for dynamic effects. However, it is not a complete tutorial. I want to fill in the gaps with this tutorial to give the reader a compilable program.
Let’s start by setting up the GHC language extensions and imports we are going to use.
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
import Effectful (Dispatch(Dynamic), DispatchOf, Eff, Effect, IOE, (:>), liftIO, runEff, runPureEff)
import Effectful.Error.Static (Error, prettyCallStack, runError, throwError)
import Effectful.Exception (catchIO)
import Effectful.Dispatch.Dynamic (interpret, reinterpret, send)
import Effectful.State.Static.Local (get, modify, runState)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified System.IO as IOThen we define a system of effects as data constructors. The type family instance type instance DispatchOf FileSystem = Dynamic marks FileSystem as dynamically dispatched, which means we can give it more than one interpretation at run time. We will give it two interpretations in this tutorial.
data FileSystem :: Effect where
ReadFile :: FilePath -> FileSystem m String
WriteFile :: FilePath -> String -> FileSystem m ()
type instance DispatchOf FileSystem = DynamicWith the use of send, we can turn the data constructors into functions. send hands an operation off to whichever interpreter is installed for FileSystem when the program runs. FileSystem is an effect required by the function. :> means FileSystem is one of the effect types in the stack of effects es.
readFile' :: (FileSystem :> es) => FilePath -> Eff es String
readFile' path = send (ReadFile path)
writeFile' :: (FileSystem :> es) => FilePath -> String -> Eff es ()
writeFile' path contents = send (WriteFile path contents)We define an interpreter for the system of effects. This gives an IO operation to each effect in the system. Start by looking at the type signature. IOE allows an arbitrary MonadIO computation. Error is an error effect we use with our custom error FsError. It allows this function to fail with FsError. interpret implements the effect and lets us implement each path in FileSystem. Each path goes through adapt, which runs the IO action and converts any IOException into our typed FsError with throwError, so failures are returned through the Error effect instead of as untyped runtime exceptions.
newtype FsError = FsError String deriving Show
runFileSystemIO
:: (IOE :> es, Error FsError :> es)
=> Eff (FileSystem : es) a
-> Eff es a
runFileSystemIO = interpret $ \_ eff ->
case eff of
ReadFile path -> adapt $ IO.readFile path
WriteFile path contents -> adapt $ IO.writeFile path contents
where
adapt m = liftIO m `catchIO` \e -> throwError . FsError $ show eThen we write a simple function that requires the FileSystem of effects and writes and reads from a text file.
writeAndReadExampleFile :: (FileSystem :> es) => Eff es String
writeAndReadExampleFile = do
writeFile' "/tmp/effectful-example.txt" "Hello from Effectful!\n"
readFile' "/tmp/effectful-example.txt"We run the effect by taking off one interpreter at a time. runFileSystemIO executes the FileSystem effect, runError @FsError executes the Error effect, and runEff executes IOE to get back to plain IO. The @FsError type application tells runError which error type to handle, since it would otherwise be ambiguous. runError turns a computation into Either (CallStack, FsError) a: a Right on success, or a Left carrying the error along with the call stack from where it was thrown. We pattern match on that in report, using prettyCallStack to render the stack as readable text. If you run this in main, it writes a file, reads the data back, and prints it to stdout.
testMain :: IO ()
testMain = do
putStrLn "== runFileSystemIO (real disk) =="
ioResult <- runEff . runError @FsError . runFileSystemIO $ writeAndReadExampleFile
report ioResult
where
report res = case res of
Left (callStack, FsError err) ->
putStrLn $ "File system error: " <> err <> "\n" <> prettyCallStack callStack
Right contents ->
putStr $ "Read back:\n" <> contentsNow we define a second interpreter for the same effect. This treats the file system as a pure Map data structure. reinterpret allows us to run an internal effect that does not exist outside of this function. In this case it is a State effect, which is what we need to thread the in-memory Map through each read and write in place of the disk. Because the file system only shows up as an effect in the type signature, we can swap in this pure interpreter and run the exact same program with no IO at all. This makes effectful code easier to test.
runFileSystemPure
:: (Error FsError :> es)
=> Map FilePath String
-> Eff (FileSystem : es) a
-> Eff es (a, Map FilePath String)
runFileSystemPure fs0 = reinterpret (runState fs0) $ \_ eff ->
case eff of
ReadFile path -> do
fs <- get
case Map.lookup path fs of
Just contents -> pure contents
Nothing -> throwError . FsError $ "no such file: " <> path
WriteFile path contents -> modify (Map.insert path contents)And an IO function for running the pure effect in main.
testPureEffect :: IO ()
testPureEffect = do
putStrLn "\n== runFileSystemPure (in-memory) =="
let pureResult = runPureEff . runError @FsError . runFileSystemPure Map.empty $ writeAndReadExampleFile
report (fmap fst pureResult)
where
report res = case res of
Left (callStack, FsError err) ->
putStrLn $ "File system error: " <> err <> "\n" <> prettyCallStack callStack
Right contents ->
putStr $ "Read back:\n" <> contentsIn order to show what error messages look like when you include an effect that is not included in the type signature, we will create a second effect system. Following the patterns from above, this should be pretty straightforward. Define the constructor, make the system dynamic, add a function for the constructor, then create an interpreter function.
data Logger :: Effect where
LogMsg :: String -> Logger m ()
type instance DispatchOf Logger = Dynamic
logMsg :: (Logger :> es) => String -> Eff es ()
logMsg msg = send (LogMsg msg)
runLoggerIO :: (IOE :> es) => Eff (Logger : es) a -> Eff es a
runLoggerIO = interpret $ \_ (LogMsg msg) -> liftIO (putStrLn ("[log] " <> msg))-- uncomment this code to see compiler error
-- this cannot compile because Logger is not part of the type signature
-- writeAndReadExampleFileBroken :: (FileSystem :> es) => Eff es String
-- writeAndReadExampleFileBroken = do
-- writeFile' "/tmp/effectful-example.txt" "Hello from Effectful with FileSystem and Logger!\n"
-- result <- readFile' "/tmp/effectful-example.txt"
-- logMsg result
-- pure resultUncommenting writeAndReadExampleFileBroken and compiling produces the following error. GHC notices that logMsg needs Logger :> es, but the type signature only promises FileSystem :> es, so it refuses to compile.
Main.lhs:193:3: error: [GHC-39999]
• Could not deduce ‘Logger :> es’ arising from a use of ‘logMsg’
from the context: FileSystem :> es
bound by the type signature for:
writeAndReadExampleFileBroken :: forall (es :: [Effect]).
(FileSystem :> es) =>
Eff es String
at Main.lhs:189:1-68
• In a stmt of a 'do' block: logMsg result
In the expression:
do writeFile'
"/tmp/effectful-example.txt"
"Hello from Effectful with FileSystem and Logger!\n"
result <- readFile' "/tmp/effectful-example.txt"
logMsg result
pure result
In an equation for ‘writeAndReadExampleFileBroken’:
writeAndReadExampleFileBroken
= do writeFile'
"/tmp/effectful-example.txt"
"Hello from Effectful with FileSystem and Logger!\n"
result <- readFile' "/tmp/effectful-example.txt"
logMsg result
....
|
193 | logMsg result
| ^^^^^^In order to make it compile, we need to add Logger to the type signature.
writeReadLogExampleFile :: (FileSystem :> es, Logger :> es) => Eff es String
writeReadLogExampleFile = do
writeFile' "/tmp/effectful-example2.txt" "Hello from Effectful with FileSystem and Logger!\n"
result <- readFile' "/tmp/effectful-example2.txt"
logMsg result
pure resultNow this function needs two effects, so we run it through two interpreters: runLoggerIO and runFileSystemIO, ahead of runError and runEff. Each one removes its effect from the stack until it reaches IO.
testLoggerEffect :: IO ()
testLoggerEffect = do
putStrLn "\n== runFileSystemIO + runLoggerIO =="
result <- runEff . runError @FsError . runFileSystemIO . runLoggerIO $ writeReadLogExampleFile
case result of
Left (callStack, FsError err) ->
putStrLn $ "File system error: " <> err <> "\n" <> prettyCallStack callStack
Right contents ->
putStr $ "Read back:\n" <> contentsmain ties the three examples together.
main :: IO ()
main = do
testMain
testPureEffect
testLoggerEffectRunning the program prints the following:
== runFileSystemIO (real disk) ==
Read back:
Hello from Effectful!
== runFileSystemPure (in-memory) ==
Read back:
Hello from Effectful!
== runFileSystemIO + runLoggerIO ==
[log] Hello from Effectful with FileSystem and Logger!
Read back:
Hello from Effectful with FileSystem and Logger!Try compiling and running this code locally. You can find the source code here.
]]>I want to learn more about Linux, C, computer networking and computer graphics. In the age of LLMs, I want to be even more conscious of what I consume and how I do programming. I use LLMs as tools to enhance my understanding. If work requires me to use agentic LLMs, I’m fine with that, but in my own personal projects I want to push my understanding further, not just blindly generate code.
So, cheers to being back!
]]>Maybe, Reader and IO into a single monad stack and access the capabilities of each monad.
A common stack is ReaderT Env IO, where Env may contain mutable references.
This is generally recommended over using WriterT and StateT for performance and safety issues.
You can read more about best practices in this FPComplete article: ReaderT Design Pattern.
You should be generally familiar with how Functor, Applicative and Monad are defined in GHC. Here is a slightly redacted version.
class Functor f where
fmap :: (a -> b) -> f a -> f b
class Functor f => Applicative f where
-- | Lift a value.
pure :: a -> f a
-- | Sequential application.
(<*>) :: f (a -> b) -> f a -> f b
(<*>) = liftA2 id
-- | Lift a binary function to actions.
liftA2 :: (a -> b -> c) -> f a -> f b -> f c
liftA2 f x = (<*>) (fmap f x)
-- | Sequence actions, discarding the value of the first argument.
(*>) :: f a -> f b -> f b
a1 *> a2 = (id <$ a1) <*> a2
-- | Sequence actions, discarding the value of the second argument.
(<*) :: f a -> f b -> f a
(<*) = liftA2 const
class Applicative m => Monad m where
-- | Sequentially compose two actions, passing any value produced
-- by the first as an argument to the second.
(>>=) :: forall a b. m a -> (a -> m b) -> m b
-- | Sequentially compose two actions, discarding any value produced
-- by the first, like sequencing operators (such as the semicolon)
-- in imperative languages.
(>>) :: forall a b. m a -> m b -> m b
m >> k = m >>= \_ -> k
-- | Inject a value into the monadic type.
return :: a -> m a
return = pure
-- | Fail with a message.
fail :: String -> m a
fail s = errorWithoutStackTrace s
join :: (Monad m) => m (m a) -> m a
join x = x >>= idThese are my one sentence motivations (not definitions) for using these type classes in Haskell:
Functor: apply a function to a value/values in a container without removing the container.
Applicative: build values from independent computations.
Monad: build values from interdependent computations.
Let’s define our own type and instances for these three type classes. I use the naming scheme from OCaml Option so we can compile
and avoid name clashes with Maybe.
import Control.Applicative (liftA2, Alternative(..))
import Control.Monad (liftM, ap, MonadPlus(..))
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class (MonadTrans(..), lift)
data Option a = None | Some a deriving (Eq, Ord, Show)
instance Functor Option where
fmap _ None = None
fmap f (Some a) = Some (f a)
instance Applicative Option where
pure = Some
Some f <*> m = fmap f m
None <*> _m = None
liftA2 f (Some x) (Some y) = Some (f x y)
liftA2 _ _ _ = None
Some _m1 *> m2 = m2
None *> _m2 = None
instance Monad Option where
(Some x) >>= k = k x
None >>= _ = None
(>>) = (*>)
fail _ = NoneHere are some motivating functions for our Monad instance. We have three functions that we want to combine:
residentToAddress :: String -> Option String
residentToAddress "Foo" = Some "10 Downing Street"
residentToAddress "Bar" = Some "1600 Pennsylvania Ave NW"
residentToAddress _ = None
addressToPhoneNumber :: String -> Option String
addressToPhoneNumber "10 Downing Street" = Some "+44 20 7925 0918"
addressToPhoneNumber "1600 Pennsylvania Ave NW" = Some "+1 202-456-1111"
addressToPhoneNumber _ = None
phoneNumberToAccountNumber :: String -> Option String
phoneNumberToAccountNumber "+44 20 7925 0918" = Some "1111-1111-1111-1111"
phoneNumberToAccountNumber "+1 202-456-1111" = Some "2222-2222-2222-2222"
phoneNumberToAccountNumber _ = None Without using monads it looks like this:
residentToAccountNumber :: String -> Option String
residentToAccountNumber r =
case residentToAddress r of
Some a ->
case addressToPhoneNumber a of
Some p -> phoneNumberToAccountNumber p
None -> None
None -> NoneUsing monads (particularly with do-syntax) we can simplify it:
residentToAccountNumberDoSyntaxSugar :: String -> Option String
residentToAccountNumberDoSyntaxSugar r = do
address <- residentToAddress r
phoneNumber <- addressToPhoneNumber address
residentToAccountNumber phoneNumber
residentToAccountNumberNoSyntaxSugar :: String -> Option String
residentToAccountNumberNoSyntaxSugar r =
residentToAddress r >>= \address -> addressToPhoneNumber address >>= \phoneNumber -> residentToAccountNumber phoneNumbernewtype OptionT m a = OptionT { runOptionT :: m (Option a) }
mapOptionT :: (m (Option a) -> n (Option b)) -> OptionT m a -> OptionT n b
mapOptionT f = OptionT . f . runOptionT
instance (Functor m) => Functor (OptionT m) where
fmap f = mapOptionT (fmap (fmap f))
instance (Functor m, Monad m) => Applicative (OptionT m) where
pure = OptionT . pure . Some
mf <*> mx = OptionT $ do
mb_f <- runOptionT mf
case mb_f of
None -> pure None
Some f -> do
mb_x <- runOptionT mx
case mb_x of
None -> pure None
Some x -> pure (Some (f x))
m *> k = m >>= \_ -> k
instance (Monad m) => Monad (OptionT m) where
return = OptionT . pure . Some
x >>= f = OptionT $ do
v <- runOptionT x
case v of
None -> pure None
Some y -> runOptionT (f y)
fail _ = OptionT (pure None)
instance MonadTrans OptionT where
lift = OptionT . liftM Some
instance (MonadIO m) => MonadIO (OptionT m) where
liftIO = lift . liftIO
instance Monad m => Alternative (OptionT m) where
empty = OptionT $ pure None
x <|> y = OptionT $ do
ov <- runOptionT x
case ov of
None -> runOptionT y
Some _ -> pure ov
instance Monad m => MonadPlus (OptionT m) where
mzero = empty
mplus = (<|>)
residentToAddressMT :: IO () -> String -> OptionT IO String
residentToAddressMT action "Foo" = do liftIO action; OptionT . pure $ Some "10 Downing Street"
residentToAddressMT action "Bar" = do liftIO action; OptionT . pure $ Some "1600 Pennsylvania Ave NW"
residentToAddressMT action _ = do liftIO action; OptionT . pure $ None
residentToAccountNumberMonadTransformer :: (OptionT IO String)
residentToAccountNumberMonadTransformer = do
r <- liftIO getLine
_a <- residentToAddressMT (print "printing from residentToAddressMT") r
-- you can wrap pure Maybe Monad
OptionT . pure $ do
address <- residentToAddress r
phoneNumber <- addressToPhoneNumber address
phoneNumberToAccountNumber phoneNumber
main :: IO ()
main = do
oaccount <- runOptionT residentToAccountNumberMonadTransformer
print oaccount1, 2, 5, the smallest set that adds up to 11 is 1, 5, 5, whereas 11 1 value coins would be the largest. Here is an outline of the recursive algorithm in imperative form (I will to convert this to real Python at some point):
coins = unique list of numbers >= 0
coin_index = length of coins
target = the value the sum of selected coins must sum, positive value
count(solution, coins, coin_index, target):
# solution has been found
if (target == 0):
return [solution];
# solution does not exist
if (target < 0):
return [];
# no more coins to iterate over, but target has not been reached
# this solution does not exist
if (coin_index <= 0 && target >= 1):
return [];
# the left branch tries a different coin
# the right branch uses the same coin, adds the coin to the solution, and
# deducts the coins value from the target
return
append(
count( solutions, coins, coin_index - 1, target)
, count(append(solutions, coins[coin_index-1]), coins, coin_index, target - coins[coin_index - 1])
)
);
return get_small_list(count([], coins, coin_index, target));The translation to Haskell is pretty straightforward. I then use a fold to get the smallest length solution. The results from makeChangesSolutions can also be used to answer how many solutions are there. You can also filter the results to answer other things like which solutions have a certain amount coin, etc.
makeChangeSolutions :: [Int] -> Int -> [[Int]]
makeChangeSolutions coins target = makeChange' [] coins (length coins) target
where
makeChange' :: [Int] -> [Int] -> Int -> Int -> [[Int]]
makeChange' coinSet coins coinIndex target
| target < 0 = []
| target == 0 = [coinSet]
| coinIndex == 0 && target >= 1 = []
| otherwise = (makeChange' coinSet coins (coinIndex - 1) target) ++ (makeChange' (coinSet ++ [coins !! (coinIndex - 1)]) coins coinIndex (target - (coins !! (coinIndex - 1))))
minimumChangeSolution :: [Int] -> Int -> [Int]
minimumChangeSolution coins target =
if length solutions == 0 then [] else foldl (\a b -> if length a < length b then a else b) (head solutions) (tail solutions)
where
solutions = makeChangeSolutions coins targetBoth these implementations are brute force though and they repeat calculations that we could save and lookup instead of recalculating them.
The dynamic programming implementation was quite challenging because I want to return not just the amount of solutions are the number of coins in the solution, but the actual soltion. Returning the former two is not too hard with some table lookups, but the latter is more challenging. I ended up referring to a Python implementation in the Problem Solving with Algorithms and Data Structures. That looks like this:
def dpMakeChange(coinValueList,change,minCoins,coinsUsed):
for cents in range(change+1):
coinCount = cents
newCoin = 1
for j in [c for c in coinValueList if c <= cents]:
if minCoins[cents-j] + 1 < coinCount:
coinCount = minCoins[cents-j]+1
newCoin = j
minCoins[cents] = coinCount
coinsUsed[cents] = newCoin
return minCoins[change]
def printCoins(coinsUsed,change):
coin = change
while coin > 0:
thisCoin = coinsUsed[coin]
print(thisCoin)
coin = coin - thisCoinMy Haskell implementation is quite complex. I ended up using two foldl which probably is not good for performance. I owe you an explanation of the code.
initMap :: Int -> Map.Map Int Int
initMap x = Map.fromList $ zip [0..x] (replicate (x+1) 0)
dpMinimumChangeSolution :: [Int] -> Int -> [Int]
dpMinimumChangeSolution coinValues change = filterUsedCoins coinsUsedMap change []
where
(_, coinsUsedMap) =
foldl (\(minCoins, coinsUsed) cents ->
let (coinCount', newCoin') = foldl (\(coinCount, newCoin) j ->
let (coinCount', newCoin') =
case Map.lookup (cents - j) minCoins of
Just res ->
if (res + 1 < coinCount)
then (res + 1, j)
else (coinCount, newCoin)
Nothing -> (coinCount, newCoin)
in (coinCount', newCoin')
) (cents, 1) (filter (\c -> c <= cents) coinValues)
in (Map.update (\_ -> Just coinCount') cents minCoins, Map.update (\_ -> Just newCoin') cents coinsUsed)
) (initMap change, initMap change) [0..change]
filterUsedCoins :: Map.Map Int Int -> Int -> [Int] -> [Int]
filterUsedCoins coinsUsed change res
| change > 0 =
case Map.lookup change coinsUsed of
Just coin -> filterUsedCoins coinsUsed (change - coin) (res ++ [coin])
Nothing -> res -- this shouldn't happen
| otherwise = resFinally the tests.
test = [1,2,3]
test2 = [1,5,10,21,25]
main :: IO ()
main = do
print $ minimumChangeSolution test 4 -- [1,3]
print $ dpMinimumChangeSolution test 4 -- [1,3]
print $ minimumChangeSolution test2 63 -- [21,21,21]
print $ dpMinimumChangeSolution test2 63 -- [21,21,21]The maximum subarray problem is an easy place to start. Given a list of numbers, what is the subarray (contiguous) that sums to the largest value. If the array only includes positive values, then it is the entire subarray. If it includes negative values, then the answer is most likely a subarray. Kadane’s algorithm provides a solution in O(n) time. Here is the imperative form:
max_so_far = 0
max_ending_here = 0
For each element in the array a:
max_ending_here = max_ending_here + a[i]
if (max_ending_here < 0)
max_ending_here = 0
if (max_so_far < max_ending_here)
max_so_far = max_ending_here
return max_so_farThe strategy is to store the max result of any subarray in max_so_far and when the loop ends, it contains the correct answer. max_ending_here contains the result from some index up to the current index. The beginning index of the subarray is reset if max_ending_here is less than zero, and max_so_far is updated only when it is less than max_ending_here.
The translation to Haskell is pretty simple. Instead of two mutable values, we create an internal function that takes the updated values of maxSoFar and maxEndingHere and call it recursively over the values of the list and when the list is empty, we return the maxSoFar value.
simpleMaxSubarray :: [Int] -> Int
simpleMaxSubarray = simpleMaxSubarray' 0 0
where
simpleMaxSubarray' maxSoFar maxEndingHere [] = maxSoFar
simpleMaxSubarray' maxSoFar maxEndingHere (x:xs) = simpleMaxSubarray' maxSoFar' maxEndingHere' xs
where
maxEndingHere' = max x (maxEndingHere + x)
maxSoFar' = max maxSoFar maxEndingHere'I decided to improve the function and return the start and end indexes of the max subarray.
maxSubarray :: [Int] -> (Int, Int, Int)
maxSubarray = maxSubarray' 0 0 0 0 0
where
maxSubarray' maxSoFar maxEndingHere i start end [] = (maxSoFar, start, end)
maxSubarray' maxSoFar maxEndingHere i start end (x:xs) =
let i' = i + 1
maxEndingHere' = maxEndingHere + x
in
if (maxSoFar < maxEndingHere')
then maxSubarray' maxEndingHere' maxEndingHere' i' start i xs
else
if maxEndingHere' < 0
-- reset the subarray we are checking
then maxSubarray' maxSoFar 0 i' i' i' xs
else maxSubarray' maxSoFar maxEndingHere' i' start end xsYou can see that the amount of values we need to pass to the function is increasing. This makes it harder to read and keep track of the values. In the future, for more complex algorithms we might consider some monadic tools like Reader, Writer and State to reduce the complexity. We will test maxSubarray below and take a look at some of the results.
test = [-2, -3, 4, -1, -2, 1, 5, -3]
test2 = [-2, 1, -3, 4, -1, 2, 1, -5, 4]
test3 = [1,2,3,4,5]
test4 = [1,2,3,4,5, -5]
main :: IO ()
main = do
print $ maxSubarray test -- (7, 2, 6)
print $ maxSubarray test2 -- (6, 3, 6)
print $ maxSubarray test3 -- (15, 0, 4)
print $ maxSubarray test4 -- (15, 0, 4){-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE UndecidableInstances #-}
import Data.Kind (Type)
import Data.Proxy (Proxy(..))
import GHC.TypeLits
type family IsZero (a :: Nat) :: Bool where
IsZero 0 = 'True
IsZero _ = 'False
type family ModRemainderIsZero (a :: Nat) (b :: Nat) where
ModRemainderIsZero a b = IsZero (Mod a b)
type family FizzBuzz' (a :: Bool) (b :: Bool) c where
FizzBuzz' 'True 'True _ = "FizzBuzz"
FizzBuzz' _ 'True _ = "Fizz"
FizzBuzz' 'True _ _ = "Buzz"
FizzBuzz' _ _ c = NatToSym cConcatSymbols is a type-level function to concat each Symbol with a line break in between each value. That way we can transform a list of Nat with NatToSym and ConcatSymbols into a single Symbol, turn it into a String and print it.
type family ConcatSymbols xs where
ConcatSymbols '[] = ""
ConcatSymbols (x ': xs) = AppendSymbol x (AppendSymbol "\n" (ConcatSymbols xs))The nicest part is he found a solution to type-level function mapping. He got the idea from (Thinking with Types Type-Level Programming in Haskell)[http://thinkingwithtypes.com/] in chapter 10. This type-level technique is called defunctionalization, which allows for higher order type-level functions in Haskell.
type Exp a = a -> Type
type family Eval (e :: Exp a) :: a
data MapList :: (a -> Exp b) -> [a] -> Exp [b]
type instance Eval (MapList f '[]) = '[]
type instance Eval (MapList f (a ': as)) = Eval (f a) ': Eval (MapList f as)
data FizzBuzz :: Nat -> Exp Symbol
type instance Eval (FizzBuzz n) = FizzBuzz' (ModRemainderIsZero n 3) (ModRemainderIsZero n 5) nNow we just need a list of Nats and we can map FizzBuzz and ConcatSymbols to get a Symbol. Much cleaner than the previous version.
type Nums = '[1,2,3,4,5,6,7,8,9,10,11,12,13,14,15]
type Result = ConcatSymbols (Eval (MapList FizzBuzz Nums))
main :: IO ()
main = putStr $ symbolVal (Proxy :: Proxy Result)One thing I have not been able to do is create a working Range type-level function that takes two Nat and returns all the numbers between them in a list. The following compiles.
type family IfThenElse cond a b where
IfThenElse 'True a _ = a
IfThenElse 'False _ b = b
type family Append xs y where
Append '[] y = '[y]
Append (x ': xs) y = x ': (Append xs y)
type family OrderToBool x where
OrderToBool 'EQ = 'True
OrderToBool _ = 'False
type family Range (x :: Nat) (y :: Nat) (zs :: [Nat]) :: [Nat] where
Range x y zs =
IfThenElse
(OrderToBool (CmpNat x y))
zs
(Range (x + 1) y (Append zs x))I want to compile and run the following, but it seems to get caught an infinite loop. The compiler suggest using the GHC flag -freduction-depth=0, but it does not seem to help. Even for small values it gets stuck.
type Result2 = ConcatSymbols (Eval (MapList FizzBuzz (Range 1 3 '[])))
main :: IO ()
main = putStr $ symbolVal (Proxy :: Proxy Result2)O(m) where m is the length of the string we search.
Here is a simple trie dictionary to give you an idea of the structure (heat, heater, help, helper, hot, hotter, hottest). The . in the trie below shows where the words end. While we can see he in the structure, it does not have a . so it is not part of the dictionary, a lookup of he returns False and of hot returns True.
h
/ |
e o
/ | |
a l t.
| | |
t. p. t
| | |
e e e
| | | \
r. r. r. s
|
t.A trie is a recursive structure. At each level it has a Bool representing a potential sequence boundary and stores a Map of Tries. The sequence boundaries have the Bool set to True and the leaf nodes have True and an empty map.
import qualified Data.Map.Lazy as Map
import Data.Maybe (fromMaybe)
data Trie a = Trie Bool (Map.Map a (Trie a)) deriving (Eq, Read, Show)An empty trie is simple.
empty :: Trie a
empty = Trie False Map.emptyTo insert and update values into a trie, we will use Map.alter Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a. Given a function f it will insert, update or delete a value a at key k. If the function returns Just it will insert (if k does not exist) or update it, if it returns Nothing than it will delete the value at k if it exists.
When the sequence is finished, we set the last node to True so that it knows there is a boundary when it looks up a sequence. While iterating throught the values of the sequence, it keeps the same Bool value, and recursively updates the child nodes at x.
insert :: Ord a => [a] -> Trie a -> Trie a
insert [] (Trie _ nodes) = Trie True nodes
insert (x:xs) (Trie end nodes) = Trie end (Map.alter (Just . insert xs . fromMaybe empty) x nodes)Now we can build a simple dictionary with insert and a helper function.
mkTrie :: Ord a => [[a]] -> Trie a
mkTrie as = mkTrie' as empty
where
mkTrie' [] trie = trie
mkTrie' (x:xs) trie = mkTrie' xs $ insert x trie
dictionary = mkTrie ["bad", "good", "heat", "heater", "help", "helper", "hot", "hotter", "hottest", "p", "pi", "sad", "said"]We should check that we can find these words in the dictionary.
member :: Ord a => [a] -> Trie a -> Bool
member [] (Trie end _) = end
member (x:xs) (Trie _ nodes) = fromMaybe False (member xs <$> Map.lookup x nodes)These return True:
λ> member "heat" dictionary
λ> member "hot" dictionary
λ> member "helper" dictionaryAnd these return False:
λ> member "he" dictionary
λ> member "hello" dictionary
λ> member "goodbye" dictionaryThis function gave me the most trouble because you need to keep track of which sequences are shared. For example, “help” and “helper” both share “help”. When we delete “helper”, we still need to keep “help”. We need to consider the following patterns when deleting:
m
|
e
/ \
t. e
|
t. h
|
e
|
a
|
t.
|
e
|
r. g b
| |
o a
| |
o d.
|
d.The main idea is to start from the top of the trie and follow the sequence all the way down, if certain conditions are met, then we can delete the sequence, if not, we continue through the subsequences checking if we can delete anything. In case we want to delete a boundary that is not at a leaf, we the list is empty, we check if there are any children, if there are we set it to False. It took a bit of trial, error and unit testing to write these functions so I will not claim that they are correct yet.
lengthOfChildNodes :: Trie a -> Int
lengthOfChildNodes (Trie _ nodes) = Map.size nodes
deletable :: Ord a => [a] -> Trie a -> Bool
deletable [] (Trie _ nodes) = Map.null nodes
deletable (x : xs) (Trie end nodes) =
(length xs == 0 || not end) &&
maybe False (\t -> deletable xs t && (length xs == 0 || (lengthOfChildNodes t) < 1)) (Map.lookup x nodes)
delete :: Ord a => [a] -> Trie a -> Trie a
delete as t = if member as t then delete' as t else t
where
delete' as@(x : xs) t@(Trie end nodes) =
if deletable as t
then Trie end (Map.delete x nodes)
else Trie end (Map.alter (Just . delete' xs . fromMaybe empty) x nodes)
delete' [] t@(Trie end nodes) = if Map.size nodes > 0 then Trie False nodes else tThe delete function is slow because it repeatedly traces over the same path as it gets smaller until it is deleted. If you need to perform delete a lot on a trie, one idea is to keep track of what paths are deletable with and extra boolean flag on each level. You would need to update the insert function to support this.
Here are the tests I used to develop the functions.
main :: IO ()
main = hspec $
describe "delete" $ do
it "forked" $ do
(member "hottest" $ delete "hotter" $ dictionary) `shouldBe` True
(member "hotter" $ delete "hottest" $ dictionary) `shouldBe` True
(member "hottest" $ delete "hottest" $ dictionary) `shouldBe` False
(member "hotter" $ delete "hotter" $ dictionary) `shouldBe` False
it "inline" $ do
(member "help" $ delete "helper" $ dictionary) `shouldBe` True
(member "helper" $ delete "help" $ dictionary) `shouldBe` True
(member "sad" $ delete "said" $ dictionary) `shouldBe` True
(member "said" $ delete "sad" $ dictionary) `shouldBe` True
(member "p" $ delete "pi" $ dictionary) `shouldBe` True
(member "pi" $ delete "p" $ dictionary) `shouldBe` True
(member "help" $ delete "help" $ dictionary) `shouldBe` False
(member "helper" $ delete "helper" $ dictionary) `shouldBe` False
(member "heat" $ delete "heat" $ dictionary) `shouldBe` False
(member "sad" $ delete "sad" $ dictionary) `shouldBe` False
(member "said" $ delete "said" $ dictionary) `shouldBe` False
(member "p" $ delete "p" $ dictionary) `shouldBe` False
(member "pi" $ delete "pi" $ dictionary) `shouldBe` False
it "separate paths" $ do
(member "bad" $ delete "good" $ dictionary) `shouldBe` True
(member "good" $ delete "bad" $ dictionary) `shouldBe` True
(member "bad" $ delete "bad" $ dictionary) `shouldBe` False
(member "good" $ delete "good" $ dictionary) `shouldBe` FalseBinary trees are a common data structure in the study of algorithms and useful for getting comfortable with new programming languages. To limit the scope of this post, we will only define a binary tree for Int instead of one that accepts a type parameter because to do it right would require using the GADTs extensions to enable the Ord and Eq restrictions on a the type parameter.
import Data.List (group, sort)
data Tree = Nil | Node Tree Int Tree deriving (Eq, Show)This is a simple recursive data structure in Haskell. Each Node constructor takes a left-side Tree, a node value, and a right-side Tree, Nil ends the recursion. A simple single Node tree with a value of 1 is defined as Node Nil 1 Nil. A three node tree is Node (Noe Nil 2 Nil) 1 (Node Nil 3 Nil). This tree looks like this:
1
/ \
2 3What would it look like to map a function over each Int value for our binary tree?
treeMap :: (Int -> Int) -> Tree -> Tree
treeMap _ Nil = Nil
treeMap f (Node l v r) = (Node (treeMap f l) (f v) (treeMap f r))If it is Nil, you just return Nil and if it is a Node, apply the function f to the value, and then call the map function on the left and right children of the Node. If you change Int to a then you can easily turn this into the Functor definition for the binary tree; change the type signature of f to (a -> a).
The various depth first traversal functions, pre-order (NLR), in-order (LNR) and post-order (LRN), are defined similarly to the map funcion above.
depthFirstPreOrder :: Tree -> [Int]
depthFirstPreOrder Nil = []
depthFirstPreOrder (Node l v r) = [v] ++ (depthFirstPreOrder l) ++ (depthFirstPreOrder l)
depthFirstInOrder :: Tree -> [Int]
depthFirstInOrder (Nil) = []
depthFirstInOrder (Node l v r) = (depthFirstInOrder l) ++ [v] ++ (depthFirstInOrder r)
depthFirstPostOrder :: Tree -> [Int]
depthFirstPostOrder (Nil) = []
depthFirstPostOrder (Node l v r) = (depthFirstPostOrder l) ++ (depthFirstPostOrder r) ++ [v]Breadth first traversal is more complex. The strategy is to build a queue and traverse it at the same time. When the Node is Nil, it continues to traverse, when the Node has a value, it adds the value to results list, and add the left and right children of the current node to the end of the queue. When the queue is empty, the results are returned, then it converts Nodes to Just x, Nil to Nothing, then uses catMaybes to turn it into [Int].
breadthFirst :: Tree -> [Int]
breadthFirst tree = catMaybes $ nodeVal <$> breadthFirst' [tree] [tree]
where
breadthFirst' :: [Tree] -> [Tree] -> [Tree]
breadthFirst' (Nil : queue) orderedNodes = breadthFirst' queue orderedNodes
breadthFirst' (Node l _ r : queue) orderedNodes = breadthFirst' (queue ++ [l,r]) (orderedNodes ++ [l,r])
breadthFirst' _ orderedNodes = orderedNodes
nodeVal :: Tree -> Maybe Int
nodeVal Nil = Nothing
nodeVal (Node _ x _) = Just xIf we want to use the binary tree as a binary search tree, each value must be a unique key, and the keys in each node are greater than or equal to the keys its left subtree and less than or equal to the keys in its right subtree. We start with a simple insert function that traverses the tree the same way a search does, but it may imbalance the tree (the height difference between one or more branches is greater than one).
insert :: Tree -> Int -> Tree
insert Nil insertVal = Node Nil insertVal Nil
insert (Node l currentNodeVal r) insertVal
| insertVal == currentNodeVal = Node l currentNodeVal r
| insertVal < currentNodeVal = Node (insert l insertVal) currentNodeVal r
| otherwise = Node l currentNodeVal (insert r insertVal)To make a balanced binary search tree, our strategy is to transform a list of values into a list of unique values that is sorted such that insert can be folded over it to create a binary search tree with values in the correct order to make it balanced. Given a list, repeteadly take the middle value, in case of even length the middle plus one, move it to the front, and repeat the process on the remaining values to the left and right of the middle value.
mkBalancedBinarySearchTreeList :: (Ord a) => [a] -> [a]
mkBalancedBinarySearchTreeList = mkBalancedBinarySearchTreeList' . sortAndRmdups
where
sortAndRmdups = map head . group . sort
mkBalancedBinarySearchTreeList' :: [a] -> [a]
mkBalancedBinarySearchTreeList' [] = []
mkBalancedBinarySearchTreeList' xs =
case length xs > 2 of
True ->
let mid = (quot (length xs) 2)
(left, right) = splitAt mid xs
(rightL, rightR) = splitAt 1 right
in rightL ++ mkBalancedBinarySearchTreeList' left ++ mkBalancedBinarySearchTreeList' rightR
False -> xs
mkTree :: [Int] -> Tree
mkTree xs = foldl insert Nil xs
mkBinaryBalancedSearchTree :: [Int] -> Tree
mkBinaryBalancedSearchTree = mkTree . mkBalancedBinarySearchTreeListNow to see if a binary search tree contains a value, traverse across the tree comparing the value, if it reaches a Node that has a matching value, then it is True, if it reaches a Nil node, then it does not exist in the tree.
contains :: Tree -> Int -> Bool
contains Nil _ = False
contains (Node t1 v t2) x
| x == v = True
| x < v = contains t1 x
| otherwise = contains t2 xdelete is the most complicated function so far. If you delete a node that has only one child, you only need to move the child up to the position of the node deleted. However, if you delete a node that has two children we need to move the minimal value of its right subtree up to the deleted node, the leftmost value, and then get that subtree without its leftmost value.
leftMost :: Tree -> Maybe Int
leftMost Nil = Nothing
leftMost (Node Nil v _) = Just v
leftMost (Node left v _) = leftMost left
rightMost :: Tree -> Maybe Int
rightMost Nil = Nothing
rightMost (Node _ v Nil) = Just v
rightMost (Node _ v r) = rightMost r
delete :: Tree -> Int -> Tree
delete Nil _ = Nil
delete (Node l v r) x
| x == v =
case (succ l r) of
Just succ' -> Node (left l r) succ' (right l r)
Nothing -> Nil
| x < v = Node (delete l x) v r
| x > v = Node l v (delete r x)
where
succ :: Tree -> Tree -> Maybe Int
succ l Nil = rightMost l
succ _ r = leftMost r
left :: Tree -> Tree -> Tree
left l Nil = leftSubtree l
left l _ = l
right :: Tree -> Tree -> Tree
right l Nil = Nil
right _ r = rightSubtree r
-- return the right subtree without the leftmost item
rightSubtree :: Tree -> Tree
rightSubtree Nil = Nil
rightSubtree (Node Nil _ r) = r
rightSubtree (Node l v r) = Node (rightSubtree l) v r
-- return the left subtree without the rightmost item
leftSubtree :: Tree -> Tree
leftSubtree Nil = Nil
leftSubtree (Node l _ Nil) = l
leftSubtree (Node l v r) = Node l v $ leftSubtree rIf you would like to learn more about binary trees in Haskell. I suggest trying to solve the binary tree problems in Ninety-Nine Haskell Problems.
]]>