Planet Haskell

by edsko, zubin, matthew at January 17, 2025 12:00 AM · not

long slow_add(long a, long b) {
  while(b--) {
    a++;
  }
  return a;
}
foreign import capi unsafe "test_cbits.h slow_add"
  c_slowAddIO :: CLong -> CLong -> IO CLong
main :: IO ()
main = do
    print =<< slowAddIO a b
    print =<< slowAddIO b a
  where
    a = 1_000_000_000
    b = 2_000_000_000
 607.16ms   607.16ms       1922573  cap 1  trace-foreign-calls: call c_slowAddIO (capi unsafe "test_cbits.h slow_add")
   0.26ms     0.00ms     609077635  cap 1  trace-foreign-calls: return c_slowAddIO

 302.02ms   302.02ms     609336093  cap 1  trace-foreign-calls: call c_slowAddIO (capi unsafe "test_cbits.h slow_add")
   0.01ms     0.00ms     911353269  cap 1  trace-foreign-calls: return c_slowAddIO
   0.00ms     0.00ms       4643217  cap 1  trace-foreign-calls: call c_slowAddIO (capi unsafe "test_cbits.h slow_add")
 856.37ms   856.37ms       4643327  cap 1  heap prof sample 0, residency 1, cost centre stack:
                                           slowAddIO in Example at Example.hs:29:1-78
                                           main in Main at test/Main.hs:(8,1)-(19,21)
                                           runMainIO1 in GHC.Internal.TopHandler at <no location info>
   0.65ms     0.00ms     861018010  cap 1  trace-foreign-calls: return c_slowAddIO

   0.00ms     0.00ms     861672464  cap 1  trace-foreign-calls: call c_slowAddIO (capi unsafe "test_cbits.h slow_add")
 426.79ms   426.79ms     861672834  cap 1  heap prof sample 0, residency 1, cost centre stack:
                                           slowAddIO in Example at Example.hs:29:1-78
                                           main in Main at test/Main.hs:(8,1)-(19,21)
                                           runMainIO1 in GHC.Internal.TopHandler at <no location info>
   0.06ms     0.00ms    1288461103  cap 1  trace-foreign-calls: return c_slowAddIO
foreign import capi "cbits.h xkcdRandomNumber"
  someFunInA :: IO CInt
main :: IO ()
main = do
    randomNumber <- someFunInA
    let bs = compress (BS.Char8.pack $ show randomNumber)
    print $ BS.Word8.unpack bs
   0.00ms     0.00ms        414047  cap 0  trace-foreign-calls: call someFunInA (capi safe "cbits.h xkcdRandomNumber")
   0.00ms     0.00ms        414607  cap 0  trace-foreign-calls: return someFunInA

(..)

   0.00ms     0.00ms        493076  cap 0  trace-foreign-calls: call c_zlibVersion (capi unsafe "zlib.h zlibVersion")
   0.00ms     0.00ms        493866  cap 0  trace-foreign-calls: return c_zlibVersion
   0.00ms     0.00ms        609576  cap 0  trace-foreign-calls: call unsafe_fdReady (ccall unsafe "fdReady")
   0.00ms     0.00ms        611846  cap 0  trace-foreign-calls: return unsafe_fdReady
   0.01ms     0.00ms        612286  cap 0  trace-foreign-calls: call c_write (capi unsafe "HsBase.h write")
   0.23ms     0.00ms        618236  cap 0  trace-foreign-calls: return c_write
MAIN . . . . . . . . . . . . . . . . . . . . . . . . 100%
MAIN . . . . . . . . . . . . . . . . . . . . . . . . 100%
└ main . . . . . . . . . . . . . . . . . . . . . . . 100%
MAIN . . . . . . . . . . . . . . . . . . . . . . . . 100%
└ main . . . . . . . . . . . . . . . . . . . . . . . 100%
  └ main.\ . . . . . . . . . . . . . . . . . . . . . 100%
MAIN . . . . . . . . . . . . . . . . . . . . . . . . 100%
└ main . . . . . . . . . . . . . . . . . . . . . . . 100%
  └ main.\ . . . . . . . . . . . . . . . . . . . . . 100%
    └ getTest  . . . . . . . . . . . . . . . . . . . 100%
MAIN . . . . . . . . . . . . . . . . . . . . . . . . 100%
└ main . . . . . . . . . . . . . . . . . . . . . . . 100%
  └ main.\ . . . . . . . . . . . . . . . . . . . . . 100%
    └ getTest  . . . . . . . . . . . . . . . . . . . 100%
      └ test . . . . . . . . . . . . . . . . . . . . 100%
MAIN . . . . . . . . . . . . . . . . . . . . . . . . 100%
└ main . . . . . . . . . . . . . . . . . . . . . . . 100%
  └ main.\ . . . . . . . . . . . . . . . . . . . . . 100%
    └ getTest  . . . . . . . . . . . . . . . . . . . 100%
      └ test . . . . . . . . . . . . . . . . . . . . 100%
        └ makeTest . . . . . . . . . . . . . . . . . 100%
          └ makeTest.\ . . . . . . . . . . . . . . . 100%
            └ compileProgram . . . . . . . . . . . . 100%
              └ evalAppT . . . . . . . . . . . . . . 100%
                └ runAppT  . . . . . . . . . . . . . 100%
                  └ runAppT' . . . . . . . . . . . . 100%
                    └ withLogging  . . . . . . . . . 100%
                      └ transformSSA . . . . . . . . 100%
                        └ >>=  . . . . . . . . . . . 100%
                          └ >>>= . . . . . . . . . . 100%
                            └ ibind  . . . . . . . . 100%
                              └ ibind.\  . . . . . . 100%
                                └ ibind.\.\  . . . . 100%
                                  ├ toSSA  . . . . . 15%
                                  ├ transform1 . . . 15%
                                  ├ transform2 . . . 10%
                                  ├ transform3 . . . 10%
                                  ├ transform4 . . . 20%
                                  └ collectGarbage . 30%
aot_compile_sticky_cache
L.LL.LL.LL
LLLLLLL.LL
L.L.L..L..
LLLL.LL.LL
L.LL.LL.LL
L.LLLLL.LL
..L.L.....
LLLLLLLLLL
L.LLLLLL.L
L.LLLLL.LL
{-# LANGUAGE GHC2021 #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}

module Main where

import Control.Arrow ((>>>))
import Control.Comonad (Comonad (..))
import Data.Function (on)
import Data.List (intercalate, nubBy)
import Data.Massiv.Array (Ix2 (..))
import Data.Massiv.Array qualified as A
import Data.Massiv.Array.Unsafe qualified as AU
import Data.Proxy (Proxy (..))
import Data.Vector.Generic qualified as VG
import Data.Vector.Generic.Mutable qualified as VGM
import Data.Vector.Unboxed qualified as VU
import System.Environment (getArgs, getProgName)
newtype Cell = Cell Char deriving (Eq)

pattern Empty, Occupied, Floor :: Cell
pattern Empty = Cell 'L'
pattern Occupied = Cell '#'
pattern Floor = Cell '.'
{-# COMPLETE Empty, Occupied, Floor #-}

parseCell :: Char -> Cell
parseCell = \case
  'L' -> Empty
  '#' -> Occupied
  '.' -> Floor
  c -> error $ "Invalid character: " <> show c

rule :: Cell -> [Cell] -> Cell
rule cell neighbours =
  let occupiedNeighboursCount = length $ filter (== Occupied) neighbours
   in case cell of
        Empty | occupiedNeighboursCount == 0 -> Occupied
        Occupied | occupiedNeighboursCount >= 4 -> Empty
        _ -> cell
class (Eq a) => Grid a where
  fromLists :: [[Cell]] -> a
  step :: a -> a
  toLists :: a -> [[Cell]]

solve :: forall a. (Grid a) => Proxy a -> [[Cell]] -> Int
solve _ =
  fromLists @a
    >>> fix step
    >>> toLists
    >>> fmap (filter (== Occupied) >>> length)
    >>> sum
  where
    fix f x = let x' = f x in if x == x' then x else fix f x'
main :: IO ()
main = do
  progName <- getProgName
  getArgs >>= \case
    [gridType, fileName] ->
      readFile fileName
        >>= (lines >>> map (map parseCell) >>> solve' gridType >>> print)
    _ -> putStrLn $ "Usage: " <> progName <> " -(z|a|s) <input_file>"
  where
    solve' = \case
      "-z" -> solve $ Proxy @(ZGrid Cell)
      "-a" -> solve $ Proxy @(AGrid Cell)
      "-s" -> solve $ Proxy @(SGrid Cell)
      _ -> error "Invalid grid type"
data Zipper a = Zipper [a] a [a] deriving (Eq, Functor)

zPosition :: Zipper a -> Int
zPosition (Zipper left _ _) = length left

zLength :: Zipper a -> Int
zLength (Zipper left _ right) = length left + 1 + length right

listToZipper :: [a] -> Zipper a
listToZipper = \case
  [] -> error "Cannot create Zipper from empty list"
  (x : xs) -> Zipper [] x xs

zipperToList :: Zipper a -> [a]
zipperToList (Zipper left focus right) = reverse left <> (focus : right)

pShowZipper :: (Show a) => Zipper a -> String
pShowZipper (Zipper left focus right) =
  unwords $
    map show (reverse left) <> (("[" <> show focus <> "]") : map show right)

zLeft :: Zipper a -> Zipper a
zLeft z@(Zipper left focus right) = case left of
  [] -> z
  x : xs -> Zipper xs x (focus : right)

zRight :: Zipper a -> Zipper a
zRight z@(Zipper left focus right) = case right of
  [] -> z
  x : xs -> Zipper (focus : left) x xs
> z = listToZipper [1..7]
> putStrLn $ pShowZipper z
[1] 2 3 4 5 6 7
> z' = zRight $ zRight $ zLeft $ zRight $ zRight z
> putStrLn $ pShowZipper z'
1 2 3 [4] 5 6 7
> zPosition z'
3
> zLength z'
7
> zipperToList z'
[1,2,3,4,5,6,7]
newtype ZGrid a = ZGrid (Zipper (Zipper a)) deriving (Eq, Functor)

zgPosition :: ZGrid a -> (Int, Int)
zgPosition (ZGrid rows@(Zipper _ focus _)) = (zPosition rows, zPosition focus)

zgSize :: ZGrid a -> (Int, Int)
zgSize (ZGrid rows@(Zipper _ focus _)) = (zLength rows, zLength focus)

listsToZGrid :: [[a]] -> ZGrid a
listsToZGrid rows =
  let (first : rest) = fmap listToZipper rows
   in ZGrid $ Zipper [] first rest

zGridToLists :: ZGrid a -> [[a]]
zGridToLists (ZGrid (Zipper left focus right)) =
  reverse (fmap zipperToList left)
    <> (zipperToList focus : fmap zipperToList right)

pShowZGrid :: (Show a) => ZGrid a -> String
pShowZGrid (ZGrid (Zipper left focus right)) =
  intercalate "\n" $ pShowRows left <> (pShowZipper focus : pShowRows right)
  where
    pShowRows = map pShowZipper'
    pShowZipper' =
      zipperToList
        >>> splitAt (zPosition focus)
        >>> \ ~(left', focus' : right') ->
          unwords $
            map show left' <> ((" " <> show focus' <> " ") : map show right')
zgUp :: ZGrid a -> ZGrid a
zgUp (ZGrid rows) = ZGrid $ zLeft rows

zgDown :: ZGrid a -> ZGrid a
zgDown (ZGrid rows) = ZGrid $ zRight rows

zgLeft :: ZGrid a -> ZGrid a
zgLeft (ZGrid rows) = ZGrid $ fmap zLeft rows

zgRight :: ZGrid a -> ZGrid a
zgRight (ZGrid rows) = ZGrid $ fmap zRight rows
> zg = listsToZGrid $ replicate 7 $ [1..7]
> putStrLn $ pShowZGrid zg
[1] 2 3 4 5 6 7
 1  2 3 4 5 6 7
 1  2 3 4 5 6 7
 1  2 3 4 5 6 7
 1  2 3 4 5 6 7
 1  2 3 4 5 6 7
 1  2 3 4 5 6 7
> zg' = zgDown $ zgRight $ zgDown $ zgRight zg
> putStrLn $ pShowZGrid zg'
1 2  3  4 5 6 7
1 2  3  4 5 6 7
1 2 [3] 4 5 6 7
1 2  3  4 5 6 7
1 2  3  4 5 6 7
1 2  3  4 5 6 7
1 2  3  4 5 6 7
> zgPosition zg'
(2,2)
> zgSize zg'
(7,7)
> zGridToLists zg'
[[1,2,3,4,5,6,7],[1,2,3,4,5,6,7],[1,2,3,4,5,6,7],[1,2,3,4,5,6,7],[1,2,3,4,5,6,7],[1,2,3,4,5,6,7],[1,2,3,4,5,6,7]]
class Functor w => Comonad w where
  extract :: w a -> a
  duplicate :: w a -> w (w a)
  extend :: (w a -> b) -> w a -> w b
  {-# MINIMAL extract, (duplicate | extend) #-}
class Comonad ZGrid where
  extract :: ZGrid Cell -> Cell
  duplicate :: ZGrid Cell -> ZGrid (ZGrid Cell)
  extend :: (ZGrid Cell -> Cell) -> ZGrid Cell -> ZGrid Cell
instance Comonad Zipper where
  extract (Zipper _ focus _) = focus
  duplicate zipper = Zipper left zipper right
    where
      pos = zPosition zipper
      left = iterateN pos zLeft $ zLeft zipper
      right = iterateN (zLength zipper - pos - 1) zRight $ zRight zipper

iterateN :: Int -> (a -> a) -> a -> [a]
iterateN n f = take n . iterate f
> z = listToZipper [1..7] :: Zipper Int
> :t duplicate z
duplicate z :: Zipper (Zipper Int)
> mapM_ (putStrLn . pShowZipper) $ zipperToList $ duplicate z
[1] 2 3 4 5 6 7
1 [2] 3 4 5 6 7
1 2 [3] 4 5 6 7
1 2 3 [4] 5 6 7
1 2 3 4 [5] 6 7
1 2 3 4 5 [6] 7
1 2 3 4 5 6 [7]
instance Comonad ZGrid where
  extract (ZGrid grid) = extract $ extract grid
  duplicate grid = ZGrid $ Zipper left focus right
    where
      (focusRowPos, focusColPos) = zgPosition grid
      (rowCount, colCount) = zgSize grid

      focus = Zipper focusLeft grid focusRight
      focusLeft = iterateN focusColPos zgLeft $ zgLeft grid
      focusRight =
        iterateN (colCount - focusColPos - 1) zgRight $ zgRight grid

      left = iterateN focusRowPos (fmap zgUp) $ fmap zgUp focus
      right =
        iterateN (rowCount - focusRowPos - 1) (fmap zgDown) $ fmap zgDown focus
> zg = listsToZGrid $ replicate 4 $ [0..3] :: ZGrid Int
> putStrLn $ pShowZGrid zg
[0] 1 2 3
 0  1 2 3
 0  1 2 3
 0  1 2 3
> :t duplicate zg
duplicate zg :: ZGrid (ZGrid Int)
> :t mapM_ (putStrLn . pShowZGrid) $ concat $ zGridToLists $ duplicate zg
mapM_ (putStrLn . pShowZGrid) $ concat $ zGridToLists $ duplicate zg :: IO ()
zGridNeighbours :: ZGrid a -> [a]
zGridNeighbours grid =
  map snd . nubBy ((==) `on` fst) $
    [ (pos, extract grid')
      | move <- moves,
        let grid' = move grid,
        let pos = zgPosition grid',
        pos /= zgPosition grid
    ]
  where
    moves =
      [ zgUp, zgDown, zgRight, zgLeft,
        zgUp >>> zgLeft, zgUp >>> zgRight,
        zgDown >>> zgLeft, zgDown >>> zgRight
      ]

stepZGrid :: ZGrid Cell -> ZGrid Cell
stepZGrid = extend $ \grid -> rule (extract grid) (zGridNeighbours grid)

instance Grid (ZGrid Cell) where
  fromLists = listsToZGrid
  step = stepZGrid
  toLists = zGridToLists
❯ nix-shell -p "ghc.withPackages (p: [p.massiv p.comonad])" \
      --run "ghc --make seating-system.hs -O2"
[1 of 2] Compiling Main             ( seating-system.hs, seating-system.o )
[2 of 2] Linking seating-system
❯ time ./seating-system -z input.txt
2243
        2.72 real         2.68 user         0.02 sys
data AGrid a = AGrid {aGrid :: A.Array A.B A.Ix2 a, aGridFocus :: A.Ix2}
  deriving (Eq, Functor)
instance Comonad AGrid where
  extract (AGrid grid focus) = grid A.! focus
  extend f (AGrid grid focus) =
    AGrid (A.compute $ A.imap (\pos _ -> f $ AGrid grid pos) grid) focus
listsToAGrid :: [[Cell]] -> AGrid Cell
listsToAGrid = A.fromLists' A.Seq >>> flip AGrid (0 :. 0)

aGridNeighbours :: AGrid a -> [a]
aGridNeighbours (AGrid grid (x :. y)) =
  [ grid A.! (x + i :. y + j)
    | i <- [-1, 0, 1],
      j <- [-1, 0, 1],
      (x + i, y + j) /= (x, y),
      validIndex (x + i, y + j)
  ]
  where
    A.Sz (rowCount :. colCount) = A.size grid
    validIndex (a, b) = and [a >= 0, b >= 0, a < rowCount, b < colCount]

stepAGrid :: AGrid Cell -> AGrid Cell
stepAGrid = extend $ \grid -> rule (extract grid) (aGridNeighbours grid)

instance Grid (AGrid Cell) where
  fromLists = listsToAGrid
  step = stepAGrid
  toLists = aGrid >>> A.toLists
❯ rm ./seating-system
❯ nix-shell -p "ghc.withPackages (p: [p.massiv p.comonad])" \
      --run "ghc --make seating-system.hs -O2"
[2 of 2] Linking seating-system
❯ time ./seating-system -a input.txt
2243
        0.10 real         0.09 user         0.00 sys
newtype instance VU.MVector s Cell = MV_Char (VU.MVector s Char)
newtype instance VU.Vector Cell = V_Char (VU.Vector Char)
deriving instance VGM.MVector VU.MVector Cell
deriving instance VG.Vector VU.Vector Cell
instance VU.Unbox Cell

type SGrid a = A.Array A.U A.Ix2 a
ruleStencil :: A.Stencil A.Ix2 Cell Cell
ruleStencil = AU.makeUnsafeStencil (A.Sz (3 :. 3)) (1 :. 1) $ \_ get ->
  rule (get (0 :. 0)) $ map get neighbourIndexes
  where
    neighbourIndexes =
      [ -1 :. -1, -1 :. 0, -1 :. 1,
         0 :. -1,           0 :. 1,
         1 :. -1,  1 :. 0,  1 :. 1
      ]

stepSGrid :: SGrid Cell -> SGrid Cell
stepSGrid = A.mapStencil (A.Fill Floor) ruleStencil >>> A.computeP

instance Grid (SGrid Cell) where
  fromLists = A.fromLists' A.Seq
  step = stepSGrid
  toLists = A.toLists
❯ rm ./seating-system
❯ nix-shell -p "ghc.withPackages (p: [p.massiv p.comonad])" \
      --run "ghc --make seating-system.hs -O2"
[2 of 2] Linking seating-system
❯ time ./seating-system -s input.txt
2243
        0.08 real         0.07 user         0.00 sys
❯ rm ./seating-system
❯ nix-shell -p "ghc.withPackages (p: [p.massiv p.comonad])" \
      --run "ghc --make seating-system.hs -O2 -threaded -rtsopts"
[2 of 2] Linking seating-system
❯ time ./seating-system -s input.txt +RTS -N
2243
        0.04 real         0.11 user         0.05 sys
f >>> g = g . f
torch.no_grad
Zpub75J9cLwa3iX1zB2oiTdvGDf4EyHWN1ZYs5gVt6JSM9THA6XLUoZhA4iZwyruCKHpw8BFf54wbAK6XdgtMLa2TgbDcftdsietCuKQ6eDPyi6

ATnhdi st hiiss  ai sm eas smaegses afgreo mf rtohme  tfhier sste ctohnrde atdh
read
AndT htihsi si si sa  am emsessasgaeg ef rformo mt hteh ef isrescto ntdh rteharde
ad
TAhnids  tihsi sa  imse sas amgees sfargoem  ftrhoem  ftihres ts etchorneda dt
hread
import Debug.NonInterleavedIO qualified as NIIO

useDebuggable :: IO ()
useDebuggable = do
    concurrently_
      ( replicateM_ 10 $ do
          NIIO.putStrLn "This is a message from the first thread"
          threadDelay 100_000
      )
      ( replicateM_ 10 $ do
          NIIO.putStrLn "And this is a message from the second thread"
          threadDelay 100_000
      )
niio output to /tmp/niio2418318-0
And this is a message from the second thread
This is a message from the first thread
And this is a message from the second thread
This is a message from the first thread
...
f1 :: IO ()
f1 = f2

f2 :: HasCallStack => IO ()
f2 = f3

f3 :: HasCallStack => IO ()
f3 = putStrLn $ prettyCallStack callStack
CallStack (from HasCallStack):
  f3, called at Demo/Provenance.hs:15:6 in ..
  f2, called at Demo/Provenance.hs:12:6 in ..
g1 :: IO ()
g1 = g2

g2 :: HasCallStack => IO ()
g2 = g3

g3 :: HasCallStack => IO ()
g3 = print callSite
g2 -> g3 (Demo/CallSite.hs:31:6)
{unknown} -> g3 (Demo/CallSite.hs:31:6)
{unknown} -> {unknown} ()
g2 -> g3 (Demo/CallSite.hs:31:6, "foo")
g1 :: IO ()
g1 = replicateM_ 2 g2

g2 :: HasCallStack => IO ()
g2 = do
    print =<< newInvocation
    replicateM_ 2 g3

g3 :: HasCallStack => IO ()
g3 = print =<< newInvocation
g2 (Demo/Invocation.hs:30:15) #1
g3 (Demo/Invocation.hs:34:16) #1
g3 (Demo/Invocation.hs:34:16) #2
g2 (Demo/Invocation.hs:30:15) #2
g3 (Demo/Invocation.hs:34:16) #3
g3 (Demo/Invocation.hs:34:16) #4
f4 :: IO ()
f4 = do
    putStrLn "f4:1"
    -- f4 does something ..
    putStrLn "f4:2"
    -- f4 does something else ..
    putStrLn "f4:3"
g4 :: HasCallStack => IO ()
g4 = do
    print =<< newInvocation
    -- f4 does something ..
    print =<< newInvocation
    -- f4 does something else ..
    print =<< newInvocation
g4 (Demo/Invocation.hs:48:15) #1
g4 (Demo/Invocation.hs:50:15) #1
g4 (Demo/Invocation.hs:52:15) #1
import Debug.NonInterleavedIO.Scoped qualified as Scoped

g4 :: HasCallStack => IO ()
g4 = do
    Scoped.putStrLn "start"
    -- f4 does something ..
    Scoped.putStrLn "middle"
    -- f4 does something else ..
    Scoped.putStrLn "end"
[g4 (Demo/Scope.hs:21:5) #1] start
[g4 (Demo/Scope.hs:23:5) #1] middle
[g4 (Demo/Scope.hs:25:5) #1] end
g1 :: IO ()
g1 = g2

g2 :: HasCallStack => IO ()
g2 = scoped g3

g3 :: HasCallStack => IO ()
g3 = scoped g4
[g4 (Demo/Scope.hs:29:5) #1, g3 (Demo/Scope.hs:25:6) #1, g2 (Demo/Scope.hs:22:6) #1] start
[g4 (Demo/Scope.hs:31:5) #1, g3 (Demo/Scope.hs:25:6) #1, g2 (Demo/Scope.hs:22:6) #1] middle
[g4 (Demo/Scope.hs:33:5) #1, g3 (Demo/Scope.hs:25:6) #1, g2 (Demo/Scope.hs:22:6) #1] end
concurrent :: IO ()
concurrent = concurrently_ g4 g4
[g4 (Demo/Scope.hs:32:5) #1] start
[g4 (Demo/Scope.hs:32:5) #2] start
[g4 (Demo/Scope.hs:34:5) #1] middle
[g4 (Demo/Scope.hs:34:5) #2] middle
[g4 (Demo/Scope.hs:36:5) #1] end
[g4 (Demo/Scope.hs:36:5) #2] end
h1 :: IO ()
h1 = h2

h2 :: HasCallStack => IO ()
h2 = scoped h3

h3 :: HasCallStack => IO ()
h3 = scoped $ do
    tid <- myThreadId
    concurrently_
      (inheritScope tid >> g4)
      (inheritScope tid >> g4)
[g4 (Demo/Scope.hs:34:5) #1, h3 (Demo/Scope.hs:50:6) #1, h2 (Demo/Scope.hs:47:6) #1] start
[g4 (Demo/Scope.hs:34:5) #2, h3 (Demo/Scope.hs:50:6) #1, h2 (Demo/Scope.hs:47:6) #1] start
[g4 (Demo/Scope.hs:36:5) #1, h3 (Demo/Scope.hs:50:6) #1, h2 (Demo/Scope.hs:47:6) #1] middle
[g4 (Demo/Scope.hs:36:5) #2, h3 (Demo/Scope.hs:50:6) #1, h2 (Demo/Scope.hs:47:6) #1] middle
[g4 (Demo/Scope.hs:38:5) #1, h3 (Demo/Scope.hs:50:6) #1, h2 (Demo/Scope.hs:47:6) #1] end
[g4 (Demo/Scope.hs:38:5) #2, h3 (Demo/Scope.hs:50:6) #1, h2 (Demo/Scope.hs:47:6) #1] end
f1 :: HasCallStack => (Int -> IO ()) -> IO ()
f1 k = f2 k

f2 :: HasCallStack => (Int -> IO ()) -> IO ()
f2 k = scoped $ k 1
g1 :: HasCallStack => Int -> IO ()
g1 n = g2 n

g2 :: HasCallStack => Int -> IO ()
g2 n = Scoped.putStrLn $ "n = " ++ show n ++ " at " ++ prettyCallStack callStack
withoutDebuggable :: HasCallStack => IO ()
withoutDebuggable = f1 g1
[g2 (Demo/Callback.hs:26:8) #1, f2 (Demo/Callback.hs:20:8) #1]
  n = 1 at CallStack (from HasCallStack):
    g2, called at Demo/Callback.hs:23:8 in ..
    g1, called at Demo/Callback.hs:29:24 in ..
    withoutDebuggable, called at Demo.hs:25:36 in ..
h1 :: HasCallStack => Callback IO Int () -> IO ()
h1 k = h2 k

h2 :: HasCallStack => Callback IO Int () -> IO ()
h2 k = scoped $ invokeCallback k 1
useDebuggable :: HasCallStack => IO ()
useDebuggable = h1 (callback g1)
[g2 (Demo/Callback.hs:26:8) #1, h2 (Demo/Callback.hs:39:8) #1]
  n = 1 at CallStack (from HasCallStack):
    g2, called at Demo/Callback.hs:23:8 in ..
    g1, called at Demo/Callback.hs:42:30 in ..
    callbackFn, called at src/Debug/Provenance/Callback.hs:57:48 in ..
    invoking callback defined at useDebuggable (Demo/Callback.hs:42:21), called at ..
    h2, called at Demo/Callback.hs:36:8 in ..
    h1, called at Demo/Callback.hs:42:17 in ..
    useDebuggable, called at Demo.hs:26:36 in ..
f1 :: (Int -> IO ()) -> IO ()
f1 k = do
    cs <- whoCreated k
    putStrLn $ "f1: invoking callback defined at " ++ show (cs)
    f2 k

f2 :: (Int -> IO ()) -> IO ()
f2 k = k 1

g1 :: Int -> IO ()
g1 n = g2 n

g2 :: Int -> IO ()
g2 n = do
    cs <- currentCallStack
    putStrLn $ "n = " ++ show n ++ " at " ++ show cs
demo :: Maybe Int -> IO ()
demo Nothing  = f1 (\x -> g1 x)
demo (Just i) = f1 (\x -> g1 (x + i))
["MAIN.DONT_CARE (<built-in>)"]
anythingToString :: forall a. a -> String
data KeycloakJSON deriving (Typeable)

instance Accept KeycloakJSON where
    contentType _ = "application" // "json"

instance MimeRender KeycloakJSON Text where
    mimeRender _ = fromStrict . encodeUtf8

    /spam/2024-10-18/…

2024-11-02
2024-11-02
        if ($date ne $self->current_date) {
          $self->mark_this_date_fully_scanned($date_dir);
        }

        if ($date lt $self->current_date) {
          $self->mark_this_date_fully_scanned($date_dir);
        }

data GroupStack g a = GroupStack (a -> g) !g [a]
push :: a -> GroupStack g a -> GroupStack g a
push a (GroupStack f g as) = GroupStack f (f a <> g) (a:as)

pop :: GroupStack g a -> Maybe (a, GroupStack g a)
pop (GroupStack f g as) = case as of
  [] -> Nothing
  (a:as') -> GroupStack f (inv (f a) <> g) as'
{-# LANGUAGE BangPatterns #-}

module Stack where

data Stack m a = Stack (a -> m) !Int [(m, a)]
new :: (a -> m) -> Stack m a
new f = Stack f 0 []

size :: Stack m a -> Int
size (Stack _ n _) = n

measure :: Monoid m => Stack m a -> m
measure (Stack _ _ as) = case as of
  [] -> mempty
  (m, _) : _ -> m
push :: Monoid m => a -> Stack m a -> Stack m a
push a s@(Stack f n as) = Stack f (n + 1) ((f a <> measure s, a) : as)

pop :: Stack m a -> Maybe (a, Stack m a)
pop (Stack f n as) = case as of
  [] -> Nothing
  (_, a) : as' -> Just (a, Stack f (n - 1) as')
measure . foldr push (new (:[])) == id
measure . foldr push (new f) == foldMap f
reverse :: Monoid m => Stack m a -> Stack m a
reverse (Stack f _ as) = foldl' (flip push) (new f) (map snd as)
{-# LANGUAGE ImportQualifiedPost #-}

module Queue where

import Data.Bifunctor (second)
import Stack (Stack)
import Stack qualified as Stack
type CommutativeMonoid = Monoid

data Queue m a = Queue {getFront :: Stack m a, getBack :: Stack m a}
  deriving (Show, Eq)

new :: (a -> m) -> Queue m a
new f = Queue (Stack.new f) (Stack.new f)

size :: Queue m a -> Int
size (Queue front back) = Stack.size front + Stack.size back

measure :: CommutativeMonoid m => Queue m a -> m
measure (Queue front back) = Stack.measure front <> Stack.measure back
enqueue :: CommutativeMonoid m => a -> Queue m a -> Queue m a
enqueue a (Queue front back) = Queue front (Stack.push a back)
dequeue :: CommutativeMonoid m => Queue m a -> Maybe (a, Queue m a)
dequeue (Queue front back)
  | Stack.size front == 0 && Stack.size back == 0 = Nothing
  | Stack.size front == 0 = dequeue (Queue (Stack.reverse back) front)
  | otherwise = second (\front' -> Queue front' back) <$> Stack.pop
  front
drop1 :: CommutativeMonoid m => Queue m a -> Queue m a
drop1 q = case dequeue q of
  Nothing -> q
  Just (_, q') -> q'
windows :: CommutativeMonoid m => Int -> (a -> m) -> [a] -> [m]
windows w f as = go startQ rest
 where
  (start, rest) = splitAt w as
  startQ = foldl' (flip enqueue) (new f) start

  go q as =
    measure q : case as of
      [] -> []
      a : as -> go (enqueue a (drop1 q)) as
data Max a = NegInf | Max a deriving (Eq, Ord, Show)

instance Ord a => Semigroup (Max a) where
  NegInf <> a = a
  a <> NegInf = a
  Max a <> Max b = Max (max a b)

instance Ord a => Monoid (Max a) where
  mempty = NegInf

data Min a = Min a | PosInf deriving (Eq, Ord, Show)

instance Ord a => Semigroup (Min a) where
  PosInf <> a = a
  a <> PosInf = a
  Min a <> Min b = Min (min a b)

instance Ord a => Monoid (Min a) where
  mempty = PosInf
$ nix shell 'gitlab:haskell-wasm/ghc-wasm-meta?host=gitlab.haskell.org'
$ wasm32-wasi-ghc --interactive
GHCi, version 9.13.20241102: https://www.haskell.org/ghc/  :? for help
ghci>
$ curl https://gitlab.haskell.org/haskell-wasm/ghc-wasm-meta/-/raw/master/bootstrap.sh | sh
...
Everything set up in /home/terrorjack/.ghc-wasm.
Run 'source /home/terrorjack/.ghc-wasm/env' to add tools to your PATH.
$ . ~/.ghc-wasm/env
$ wasm32-wasi-ghc --interactive
GHCi, version 9.13.20241102: https://www.haskell.org/ghc/  :? for help
ghci>
ghci> :{
ghci| fib :: Int -> Int
ghci| fib 0 = 0
ghci| fib 1 = 1
ghci| fib n = fib (n - 2) + fib (n - 1)
ghci| :}
ghci> fib 10
55
ghci> :{
ghci| fib :: Int -> Int
ghci| fib = (fibs !!)
ghci|   where
ghci|     fibs = 0 : 1 : zipWith (+) fibs (drop 1 fibs)
ghci| :}
ghci> fib 32
2178309
ghci> import Language.Haskell.TH
ghci> :{
ghci| genFib :: Int -> Q Exp
ghci| genFib n =
ghci|   pure $
ghci|     LamCaseE
ghci|       [ Match (LitP $ IntegerL $ fromIntegral i) (NormalB $ LitE $ IntegerL r) []
ghci|       | (i, r) <- zip [0 .. n] fibs
ghci|       ]
ghci|   where
ghci|     fibs = 0 : 1 : zipWith (+) fibs (drop 1 fibs)
ghci| :}
ghci> :set -XTemplateHaskell
ghci> :{
ghci| fib :: Int -> Int
ghci| fib = $(genFib 32)
ghci| :}
ghci> fib 32
2178309
$ wasm32-wasi-ghc --interactive -opti-v
GHCi, version 9.13.20241102: https://www.haskell.org/ghc/  :? for help
GHC iserv starting (in: {handle: <file descriptor: 2147483646>}; out: {handle: <file descriptor: 2147483647>})
[             dyld.so] reading pipe...
[             dyld.so] discardCtrlC
...
[             dyld.so] msg: AddLibrarySearchPath ...
...
[             dyld.so] msg: LoadDLL ...
...
[             dyld.so] msg: LookupSymbol "ghczminternal_GHCziInternalziBase_thenIO_closure"
[             dyld.so] writing pipe: Just (RemotePtr 2950784)
...
[             dyld.so] msg: CreateBCOs ...
[             dyld.so] writing pipe: [RemoteRef (RemotePtr 33)]
...
[             dyld.so] msg: EvalStmt (EvalOpts {useSandboxThread = True, singleStep = False, breakOnException = False, breakOnError = False}) (EvalApp (EvalThis (RemoteRef (RemotePtr 34))) (EvalThis (RemoteRef (RemotePtr 33))))
4
[             dyld.so] writing pipe: EvalComplete 15248 (EvalSuccess [RemoteRef (RemotePtr 36)])
...
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Main where

import Control.Category ((>>>))
import Control.Monad.ST
import Data.Bits
import Data.ByteString.Lazy.Char8 (ByteString)
import Data.ByteString.Lazy.Char8 qualified as BS

import ScannerBS
import UnionFind qualified as UF

main = BS.interact $ runScanner tc >>> solve >>> format

format :: [Maybe Int] -> ByteString
format = map (maybe "-1" (show >>> BS.pack)) >>> BS.unlines
-- Each edge is a "filter" represented as a bitstring stored as an Int.
newtype Filter = Filter Int
  deriving (Eq, Show)

instance Semigroup Filter where
  Filter x <> Filter y = Filter (x .|. y)

filterSize :: Filter -> Int
filterSize (Filter f) = popCount f

data Channel = Channel UF.Node UF.Node Filter deriving (Eq, Show)
data TC = TC {n :: !Int, channels :: [Channel], queries :: [(Int, Int)]}
  deriving (Eq, Show)

tc :: Scanner TC
tc = do
  n <- int
  m <- int
  q <- int
  channels <- m >< (Channel <$> int <*> int <*> (Filter <$> int))
  queries <- q >< pair int int
  return TC {..}
solve :: TC -> [Maybe Int]
solve TC {..} = runST $ do
  uf <- UF.new (n + 1) (Filter 0)
  mapM_ (addChannel uf) channels
  mapM (answer uf) queries

addChannel :: UF.UnionFind s Filter -> Channel -> ST s ()
addChannel uf (Channel a b f) = do
  UF.union uf a b
  UF.updateAnn uf a f

answer :: UF.UnionFind s Filter -> (Int, Int) -> ST s (Maybe Int)
answer uf (a, b) = do
  c <- UF.connected uf a b
  case c of
    False -> pure Nothing
    True -> Just . filterSize <$> UF.getAnn uf a
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE RecordWildCards #-}

import Control.Category ((>>>))
import Control.Monad.ST
import Data.ByteString.Lazy.Char8 qualified as BS
import Data.List (sort)
import Data.Ord (comparing)
import Data.STRef
import ScannerBS
import UnionFind qualified as UF

main = BS.interact $ runScanner (numberOf tc) >>> map (solve >>> show >>> BS.pack) >>> BS.unlines

data Edge = Edge {a :: !Int, b :: !Int, w :: !Integer}
  deriving (Eq, Show)

instance Ord Edge where
  compare = comparing w

data TC = TC {n :: !Int, edges :: [Edge]}
  deriving (Eq, Show)

tc :: Scanner TC
tc = do
  n <- int
  edges <- (n - 1) >< (Edge <$> int <*> int <*> integer)
  return TC {..}
solve :: TC -> Integer
solve TC {..} = runST $ do
  uf <- UF.new (n + 1)
  total <- newSTRef (0 :: Integer)
  mapM_ (processEdge uf total) (sort edges)
  readSTRef total

processEdge :: UF.UnionFind s -> STRef s Integer -> Edge -> ST s ()
processEdge uf total (Edge a b w) = do
  modifySTRef' total (+ w)
  sa <- UF.size uf a
  sb <- UF.size uf b
  modifySTRef' total (+ (fromIntegral sa * fromIntegral sb - 1) * (w + 1))
  UF.union uf a b
module Example where

x :: Int
x = 5

y :: Int
y = x + 1
y :: Int
y = 5 + 1
y :: Int
y = 6
$ ghc -O2 -fforce-recomp -ddump-simpl -dsuppress-all Example.hs
==================== Tidy Core ====================
Result size of Tidy Core
  = {terms: 20, types: 7, coercions: 0, joins: 0/0}

x = I# 5#

$trModule4 = "main"#

$trModule3 = TrNameS $trModule4

$trModule2 = "Example"#

$trModule1 = TrNameS $trModule2

$trModule = Module $trModule3 $trModule1

y = I# 6#
x = 5

y = 6
f :: Int -> Int
f x = x + 1

y :: Int
y = f 5
y :: Int
y = 5 + 1
y = I# 6#
-- Here `f` is our type variable
example :: Functor f => f Int -> f Int
example = fmap (+ 1)
example2 :: Maybe Int -> Maybe Int
example2 = fmap (+ 1)
example @f $Functor = fmap $Functor (\v -> v + 1)

example2 Nothing = Nothing
example2 (Just a) = Just (a + 1)
example :: Functor f => f Int -> f Int
example = fmap (+ 1)

example2 :: Maybe Int -> Maybe Int
example2 = example
example2 :: Maybe Int -> Maybe Int
example2 = example
example2 = example @Maybe $FunctorMaybe
$ ghc -O0 -fforce-recomp -ddump-simpl Example.hs
…

example2 = example @Maybe $FunctorMaybe
…
$ ghc -O2 -fforce-recomp -ddump-simpl -dsuppress-all Example.hs
example2 Nothing = Nothing
example2 (Just a) = Just (a + 1)
f :: Int -> Int
f x = x + 1
{-# INLINABLE f #-}
f :: Int -> Int
f x = x + 1
{-# INLINE f #-}
f :: Int -> Int
f x = x + 1
{-# NOINLINE f #-}
example :: Functor f => f Int -> f Int
example = fmap (+ 1)
example :: Functor f => f Int -> f Int
example = fmap (+ 1)
{-# SPECIALIZE example :: Maybe Int -> Maybe Int #-}
const success: Effect.Effect<number, never, never> = Effect.succeed(42)

const fail: Effect.Effect<never, Error, never> = Effect.fail(
  new Error("Something went wrong")
)
const divide = (a: number, b: number): Effect.Effect<number, Error, never> =>
  b === 0
    ? Effect.fail(new Error("Cannot divide by zero"))
    : Effect.succeed(a / b)
// Synchronous function that can't fail
const log = (message: string): Effect.Effect<void, never, never> =>
  Effect.sync(() => console.log(message))

// Asynchronous function that can't fail
const delay = (message: string): Effect.Effect<string, never, never> =>
  Effect.promise<string>(
    () =>
      new Promise(resolve => {
        setTimeout(() => {
          resolve(message)
        }, 2000)
      })
  )

// Synchronous function that can fail
const parse = (input: string): Effect.Effect<any, Error, never> =>
  Effect.try({
    // JSON.parse may throw for bad input
    try: () => JSON.parse(input),
    // remap the error
    catch: _unknown => new Error(`something went wrong while parsing the JSON`),
  })

// Asynchronous function that can fail
const getTodo = (id: number): Effect.Effect<Response, Error, never> =>
  Effect.tryPromise({
    // fetch can throw for network errors
    try: () => fetch(`https://jsonplaceholder.typicode.com/todos/${id}`),
    // remap the error
    catch: unknown => new Error(`something went wrong ${unknown}`),
  })
Effect.runPromise(delay("Hello, World!")).then(console.log)
// -> Hello, World! (after 2 seconds)
const double = (n: number) => n * 2

const divide =
  (b: number) =>
  (a: number): Effect.Effect<number, Error> =>
    b === 0
      ? Effect.fail(new Error("Cannot divide by zero"))
      : Effect.succeed(a / b)

const increment = (n: number) => Effect.succeed(n + 1)

const result = pipe(
  42,
  // Here we have an Effect.Effect<number, Error> with the value 21
  divide(2),
  // To run a function over the value changing the effect's value, we use Effect.map
  Effect.map(double),
  // To run a function over the value without changing the effect's value, we use Effect.tap
  Effect.tap(n => console.log(`The double is ${n}`)),
  // To run a function that returns a new effect, we use Effect.andThen
  Effect.andThen(increment),
  Effect.tap(n => console.log(`The incremented value is ${n}`))
)

Effect.runSync(result)
// -> The double is 42
// -> The incremented value is 43
mkdir weather-app
cd weather-app
npm init -y
npm install --save-dev parcel
mkdir src
touch src/index.html
touch src/styles.scss
touch src/index.ts
{
  "source": "./src/index.html",
  "scripts": {
    "dev": "parcel",
    "build": "parcel build"
  }
}
npm run dev

Server running at http://localhost:1234
✨ Built in 8ms
// The field input
const cityElement = document.querySelector<HTMLInputElement>("#city")
// The list of suggestions
const citiesElement = document.querySelector<HTMLUListElement>("#cities")
// The weather information
const weatherElement = document.querySelector<HTMLDivElement>("#weather")
npm install zod
import { z } from "zod"

// ...

const CityResponse = z.object({
  name: z.string(),
  country_code: z.string().length(2),
  latitude: z.number(),
  longitude: z.number(),
})

const GeocodingResponse = z.object({
  results: z.array(CityResponse),
})
type CityResponse = z.infer<typeof CityResponse>

type GeocodingResponse = z.infer<typeof GeocodingResponse>
const getCity = async (city: string): Promise<CityResponse[]> => {
  try {
    const response = await fetch(
      `https://geocoding-api.open-meteo.com/v1/search?name=${city}&count=10&language=en&format=json`
    )

    // Convert the response to JSON
    const geocoding = await response.json()

    // Parse the response using the GeocodingResponse schema
    const parsedGeocoding = GeocodingResponse.safeParse(geocoding)

    if (!parsedGeocoding.success) {
      return []
    }

    return parsedGeocoding.data.results
  } catch (error) {
    console.error("Error:", error)
    return []
  }
}
const getCities = async function (input: HTMLInputElement) {
  const { value } = input

  // Check if the HTML element exists
  if (citiesElement) {
    // Clear the list of suggestions
    citiesElement.innerHTML = ""
  }

  // Check if the input is empty
  if (!value) {
    return
  }

  // Fetch the cities
  const results = await getCity(value)

  renderCitySuggestions(results)
}

cityElement?.addEventListener("input", function (_event) {
  getCities(this)
})
const renderCitySuggestions = (cities: CityResponse[]) => {
  // If there are cities, populate the suggestions
  if (cities.length > 0) {
    populateSuggestions(cities)
    return
  }

  // Otherwise, show a message that the city was not found
  if (weatherElement) {
    const search = cityElement?.value || "searched"
    weatherElement.innerHTML = `<p>City ${search} not found</p>`
  }
}
const populateSuggestions = (results: CityResponse[]) =>
  results.forEach(city => {
    const li = document.createElement("li")
    li.innerText = `${city.name} - ${city.country_code}`
    citiesElement?.appendChild(li)
  })
const selectCity = async (result: CityResponse) => {
  // If the HTML element doesn't exist, return
  if (!weatherElement) {
    return
  }

  try {
    const data = await getWeather(result)

    if (data.tag === "error") {
      throw data.value
    }

    const {
      temperature_2m,
      apparent_temperature,
      relative_humidity_2m,
      precipitation,
    } = data.value.current

    weatherElement.innerHTML = `
 <h2>${result.name}</h2>
 <p>Temperature: ${temperature_2m}°C</p>
 <p>Feels like: ${apparent_temperature}°C</p>
 <p>Humidity: ${relative_humidity_2m}%</p>
 <p>Precipitation: ${precipitation}mm</p>
 `
  } catch (error) {
    weatherElement.innerHTML = `<p>An error occurred while fetching the weather: ${error}</p>`
  }
}
const populateSuggestions = (results: CityResponse[]) =>
  results.forEach(city => {
    // ...
    li.addEventListener("click", () => selectCity(city))
    citiesElement?.appendChild(li)
  })
type WeatherResult =
  | { tag: "ok"; value: WeatherResponse }
  | { tag: "error"; value: unknown }

const WeatherResponse = z.object({
  current_units: z.object({
    temperature_2m: z.string(),
    relative_humidity_2m: z.string(),
    apparent_temperature: z.string(),
    precipitation: z.string(),
  }),
  current: z.object({
    temperature_2m: z.number(),
    relative_humidity_2m: z.number(),
    apparent_temperature: z.number(),
    precipitation: z.number(),
  }),
})

type WeatherResponse = z.infer<typeof WeatherResponse>

const getWeather = async (result: CityResponse): Promise<WeatherResult> => {
  try {
    const response = await fetch(
      `https://api.open-meteo.com/v1/forecast?latitude=${result.latitude}&longitude=${result.longitude}&current=temperature_2m,relative_humidity_2m,apparent_temperature,precipitation&timezone=auto&forecast_days=1`
    )

    // Convert the response to JSON
    const weather = await response.json()

    // Parse the response using the WeatherResponse schema
    const parsedWeather = WeatherResponse.safeParse(weather)

    if (!parsedWeather.success) {
      return { tag: "error", value: parsedWeather.error }
    }

    return { tag: "ok", value: parsedWeather.data }
  } catch (error) {
    return { tag: "error", value: error }
  }
}
npm install lodash
npm install --save-dev @types/lodash
import { debounce } from "lodash"

// ...

const getCities = debounce(async function (input: HTMLInputElement) {
  // The same code as before
}, 500)
npm install effect
import { Option } from "effect"

// The field input
const cityElement = Option.fromNullable(
  document.querySelector<HTMLInputElement>("#city")
)
// The list of suggestions
const citiesElement = Option.fromNullable(
  document.querySelector<HTMLUListElement>("#cities")
)
// The weather information
const weatherElement = Option.fromNullable(
  document.querySelector<HTMLDivElement>("#weather")
)
import { /* ... */, Effect, Scope, pipe } from "effect";
import { Schema } from "@effect/schema"
import {
  FetchHttpClient,
  HttpClient,
  HttpClientResponse,
  HttpClientError
} from "@effect/platform";

// ...

const CityResponse = Schema.Struct({
  name: Schema.String,
  country_code: pipe(Schema.String, Schema.length(2)),
  latitude: Schema.Number,
  longitude: Schema.Number,
})

type CityResponse = Schema.Schema.Type<typeof CityResponse>

const GeocodingResponse = Schema.Struct({
  results: Schema.Array(CityResponse),
})

type GeocodingResponse = Schema.Schema.Type<typeof GeocodingResponse>

const getRequest = (url: string): Effect.Effect<HttpClientResponse.HttpClientResponse, HttpClientError.HttpClientError, Scope.Scope> =>
  pipe(
    HttpClient.HttpClient,
    // Using `Effect.andThen` to get the client from the `HttpClient.HttpClient` tag and then make the request
    Effect.andThen(client => client.get(url)),
    // We don't need to send the tracing headers to the API to avoid CORS errors
    HttpClient.withTracerPropagation(false),
    // Providing the HTTP client to the effect
    Effect.provide(FetchHttpClient.layer)
  )

const getCity = (city: string): Effect.Effect<readonly CityResponse[], never, never> =>
  pipe(
    getRequest(
      `https://geocoding-api.open-meteo.com/v1/search?name=${city}&count=10&language=en&format=json`
    ),
    // Validating the response using the `GeocodingResponse` schema
    Effect.andThen(HttpClientResponse.schemaBodyJson(GeocodingResponse)),
    // Providing a default value in case of failure
    Effect.orElseSucceed<GeocodingResponse>(() => ({ results: [] })),
    // Extracting the `results` array from the `GeocodingResponse` object
    Effect.map(geocoding => geocoding.results),
    // Providing a scope to the effect
    Effect.scoped
  )
import { /* ... */, Effect, Option, pipe } from "effect";

// ...

const getCities = (search: string): Effect.Effect<Option.Option<void>, never, never> => {
  Option.map(citiesElement, citiesEl => (citiesEl.innerHTML = ""))

  return pipe(
    getCity(search),
    Effect.map(renderCitySuggestions),
    // Check if the input is empty
    Effect.when(() => Boolean(search))
  )
}
import { /* ... */, Effect, Option, pipe, Stream, Chunk, StreamEmit } from "effect";

// ...

Option.map(cityElement, cityEl => {
  const stream = Stream.async(
    (emit: StreamEmit.Emit<never, never, string, void>) =>
      cityEl.addEventListener("input", function (_event) {
        emit(Effect.succeed(Chunk.of(this.value)))
      })
  )

  pipe(
    stream,
    Stream.debounce(500),
    Stream.runForEach(getCities),
    Effect.runPromise
  )
})
import { /* ... */, Array, Option, pipe } from "effect";

// ...

const renderCitySuggestions = (cities: readonly CityResponse[]): void | Option.Option<void> =>
  // If there are multiple cities, populate the suggestions
  // Otherwise, show a message that the city was not found
  pipe(
    cities,
    Array.match({
      onNonEmpty: populateSuggestions,
      onEmpty: () => {
        const search = Option.match(cityElement, {
          onSome: (cityEl) => cityEl.value,
          onNone: () => "searched",
        });

        Option.map(
          weatherElement,
          (weatherEl) =>
            (weatherEl.innerHTML = `<p>City ${search} not found</p>`),
        );
      },
    }),
  );
import { /* ... */, Option, pipe } from "effect";

// ...

const selectCity = (result: CityResponse): Option.Option<Promise<string>> =>
  Option.map(weatherElement, weatherEl =>
    pipe(
      result,
      getWeather,
      Effect.match({
        onFailure: error =>
          (weatherEl.innerHTML = `<p>An error occurred while fetching the weather: ${error}</p>`),
        onSuccess: (weatherData: WeatherResponse) =>
          (weatherEl.innerHTML = `
<h2>${result.name}</h2>
<p>Temperature: ${weatherData.current.temperature_2m}°C</p>
<p>Feels like: ${weatherData.current.apparent_temperature}°C</p>
<p>Humidity: ${weatherData.current.relative_humidity_2m}%</p>
<p>Precipitation: ${weatherData.current.precipitation}mm</p>
`),
      }),
      Effect.runPromise
    )
  )
import { /* ... */, Effect, pipe } from "effect";
import { Schema, ParseResult } from "@effect/schema";
import { /* ... */, HttpClientResponse, HttpClientError } from "@effect/platform";

// ...

const WeatherResponse = Schema.Struct({
  current_units: Schema.Struct({
    temperature_2m: Schema.String,
    relative_humidity_2m: Schema.String,
    apparent_temperature: Schema.String,
    precipitation: Schema.String,
  }),
  current: Schema.Struct({
    temperature_2m: Schema.Number,
    relative_humidity_2m: Schema.Number,
    apparent_temperature: Schema.Number,
    precipitation: Schema.Number,
  }),
})

type WeatherResponse = Schema.Schema.Type<typeof WeatherResponse>

const getWeather = (
  result: CityResponse,
): Effect.Effect<WeatherResponse, HttpClientError.HttpClientError | ParseResult.ParseError, never> =>
  pipe(
    getRequest(
      `https://api.open-meteo.com/v1/forecast?latitude=${result.latitude}&longitude=${result.longitude}&current=temperature_2m,relative_humidity_2m,apparent_temperature,precipitation&timezone=auto&forecast_days=1`
    ),
    Effect.andThen(HttpClientResponse.schemaBodyJson(WeatherResponse)),
    Effect.scoped
  )
torch.compiler.disable
fullgraph=True
mode="max-autotune"
traverse :: Applicative f => (a -> f b) -> Map k a -> f (Map k b)
liftA2 (,) :: Applicative f => f a -> f b -> f (a, b)
-- A part of list's shape is its length and the monoid is (*, 1)
length (xs <*> ys) == length xs * length ys
length (pure r) == 1

-- Maybe's shape is isJust and the monoid is (&&, True)
isJust (mx <*> my) == isJust mx && isJust my
isJust (pure r) = True

-- State's shape is execState and the monoid is (flip (.), id)
execState (sx <*> sy) == execState sy . execState sx
execState (pure r) == id

-- Writer's shape is execWriter and the monoid is (<>, mempty)
execWriter (wx <*> wy) == execWriter wx <> execWriter wy
execWriter (pure r) == mempty
-- A part of ZipList's shape is length and its monoid is (min, infinity)
length (xs <*> ys) == length xs `min` length ys
length (pure r) == infinity
ghci> "hello" <> "world"
"helloworld"
ghci> getDual $ Dual "hello" <> Dual "world"
"worldhello"
ghci> putStrLn "hello" *> putStrLn "world"
hello
world
ghci> forwards $ Backwards (putStrLn "hello") *> Backwards (putStrLn "world")
world
hello
(<|>) :: Alternative f => f a -> f a -> f a
liftA2 (,) :: Applicative f => f a -> f b -> f (a, b)
-- A part of list's shape is its length:
-- the Ap monoid is (*, 1), the Alt monoid is (+, 0)
length (xs <*> ys) == length xs * length ys
length (pure r) == 1
length (xs <|> ys) == length xs + length ys
length empty == 0

-- Maybe's shape is isJust:
-- The Ap monoid is (&&, True), the Alt monoid is (||, False)
isJust (mx <*> my) == isJust mx && isJust my
isJust (pure r) = True
isJust (mx <|> my) == isJust mx || isJust my
isJust empty = False
liftA2 (,) :: Applicative f => f a -> f b -> f (a, b)
(<|>) :: Alternative f => f a -> f a -> f a
(>>=) :: Monad m => m a -> (a -> m b) -> m b
greet = do
  putStrLn "What is your name?"
  n <- getLine
  putStrLn ("Hello, " ++ n ++ "!")
evenProducts :: [Int] -> [Int] -> [Bool]
evenProducts xs ys = (\x y -> even (x * y)) <$> xs <*> ys
evenProducts :: [Int] -> [Int] -> [(Int, Int)]
evenProducts xs ys = do
  x <- xs
  y <- ys
  guard (even (x * y))
  pure (x, y)
data Option a = Option { optionName :: String, optionParse :: String -> Maybe a }
  deriving Functor
type Parser = Ap Option
data Args = Args { myStringOpt :: String, myIntOpt :: Int }

parseTwo :: Parser args
parseTwo = Args <$> liftAp stringOpt <*> liftAp intOpt
  where
    stringOpt = Option "string-opt" Just
    intOpt = Option "int-opt" readMaybe

getAllOptions :: Parser a -> [String]
getAllOptions = runAp_ (\o -> [optionName o])
ghci> getAllOptions parseTwo
["string-opt", "int-opt"]
newtype Single a = Single { satisfies :: Char -> Maybe a }
  deriving Functor
type Parser = Free Single
{-# LANGUAGE RecordWildCards #-}

module UnionFind where

import Control.Monad (when)
import Control.Monad.ST
import Data.Array.ST
type Node = Int
data UnionFind s m = UnionFind {
  parent :: !(STUArray s Node Node),
  sz :: !(STUArray s Node Int),
  ann :: !(STArray s Node m) }
createWith :: Int -> (Node -> m) -> ST s (UnionFind s m)
createWith n m =
  UnionFind
    <$> newListArray (0, n - 1) [0 .. n - 1]    -- Every node is its own parent
    <*> newArray (0, n - 1) 1                   -- Every node has size 1
    <*> newListArray (0, n - 1) (map m [0 .. n - 1])

create :: Int -> m -> ST s (UnionFind s m)
create n m = createWith n (const m)
find :: UnionFind s m -> Node -> ST s Node
find uf@(UnionFind {..}) x = do
  p <- readArray parent x
  if p /= x
    then do
      r <- find uf p
      writeArray parent x r
      pure r
    else pure x

connected :: UnionFind s m -> Node -> Node -> ST s Bool
connected uf x y = (==) <$> find uf x <*> find uf y
union :: Semigroup m => UnionFind s m -> Node -> Node -> ST s ()
union uf@(UnionFind {..}) x y = do
  x <- find uf x
  y <- find uf y
  when (x /= y) $ do
    sx <- readArray sz x
    sy <- readArray sz y
    mx <- readArray ann x
    my <- readArray ann y
    if sx < sy
      then do
        writeArray parent x y
        writeArray sz y (sx + sy)
        writeArray ann y (mx <> my)
      else do
        writeArray parent y x
        writeArray sz x (sx + sy)
        writeArray ann x (mx <> my)
size :: UnionFind s m -> Node -> ST s Int
size uf@(UnionFind {..}) x = do
  x <- find uf x
  readArray sz x
updateAnn :: Semigroup m => UnionFind s m -> Node -> m -> ST s ()
updateAnn uf@(UnionFind {..}) x m = do
  x <- find uf x
  old <- readArray ann x
  writeArray ann x (old <> m)
  -- We could use modifyArray above, but the version of the standard library
  -- installed on Kattis doesn't have it

getAnn :: UnionFind s m -> Node -> ST s m
getAnn uf@(UnionFind {..}) x = do
  x <- find uf x
  readArray ann x
module Language.FiboLisp.Types where

import Data.Text qualified as Text
import Data.Text.Lazy qualified as LText
import Text.Pretty.Simple qualified as PS
import Text.Printf (printf)

type Ident = String

data Expr
  = Num_ Integer
  | Bool_ Bool
  | Var Ident
  | BinaryOp Op Expr Expr
  | If Expr Expr Expr
  | Apply Ident [Expr]
  deriving (Show)

data Op = Add | Sub | LessThan
  deriving (Show, Enum)

data Def = Def {defName :: Ident, defParams :: [Ident], defBody :: Expr}

data Program = Program [Def] [Expr]
  deriving (Show)

carKeywords :: [String]
carKeywords = ["def", "if", "+", "-", "<"]

instance Show Def where
  show Def {..} =
    printf "(Def %s [%s] (%s))" defName (unwords defParams) (show defBody)

showProgram :: Program -> String
showProgram =
  Text.unpack
    . LText.toStrict
    . PS.pShowOpt
      ( PS.defaultOutputOptionsNoColor
          { PS.outputOptionsIndentAmount = 2,
            PS.outputOptionsCompact = True,
            PS.outputOptionsCompactParens = True
          }
      )
(def fibo [n]
  (if (< n 2)
    n
    (+ (fibo (- n 1)) (fibo (- n 2)))))
module Language.FiboLisp.Parser (ParsingError(..), parse) where

import Control.DeepSeq (NFData)
import Control.Exception (Exception)
import GHC.Generics (Generic)
import Language.FiboLisp.Types

parse :: String -> Either ParsingError Program

data ParsingError = ParsingError String | EndOfStreamError
  deriving (Show, Generic, NFData)

instance Exception ParsingError
module Language.FiboLisp.Printer (prettyShowDef) where

import Language.FiboLisp.Types

prettyShowDef :: Def -> String
module Language.FiboLisp.Interpreter
  (Value, RuntimeError, interpret, builtinFuncs, builtinVals) where

import Control.DeepSeq (NFData)
import Control.Exception (Exception)
import Data.Map.Strict qualified as Map
import GHC.Generics (Generic)
import Language.FiboLisp.Types

interpret :: (String -> IO ()) -> Program -> IO (Either RuntimeError Value)

newtype RuntimeError = RuntimeError String
  deriving (Show, Generic, NFData)

instance Exception RuntimeError

data Value = ...
  deriving (Show, Generic, NFData)

builtinFuncs :: Map.Map String Value

builtinVals :: [Value]
module Language.FiboLisp
  ( module Language.FiboLisp.Types,
    module Language.FiboLisp.Parser,
    module Language.FiboLisp.Printer,
    module Language.FiboLisp.Interpreter,
  )
where

import Language.FiboLisp.Interpreter
import Language.FiboLisp.Parser
import Language.FiboLisp.Printer
import Language.FiboLisp.Types
{-# LANGUAGE TemplateHaskell #-}

module Language.FiboLisp.Repl (run) where

import Control.DeepSeq qualified as DS
import Control.Exception (Exception (..), evaluate)
import Control.Lens.Basic qualified as Lens
import Control.Monad (when)
import Control.Monad.Catch qualified as Catch
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Identity (IdentityT (..))
import Control.Monad.Reader (MonadReader, ReaderT (runReaderT))
import Control.Monad.Reader qualified as Reader
import Control.Monad.State.Strict (MonadState, StateT (runStateT))
import Control.Monad.State.Strict qualified as State
import Control.Monad.Trans (MonadTrans, lift)
import Data.Char qualified as Char
import Data.Functor ((<&>))
import Data.List
  (dropWhileEnd, foldl', isPrefixOf, isSuffixOf, nub, sort, stripPrefix)
import Data.Map.Strict qualified as Map
import Data.Maybe (fromJust)
import Data.Set qualified as Set
import Data.Time (NominalDiffTime, diffUTCTime, getCurrentTime)
import Language.FiboLisp qualified as L
import System.Console.Haskeline qualified as H
import System.Console.Terminfo qualified as Term
import System.Directory (canonicalizePath, doesFileExist, getCurrentDirectory)
data ReplState = ReplState
  { _replDefs :: Defs,
    _replSettings :: Settings,
    _replLineMode :: LineMode,
    _replIndent :: Int,
    _replSeenInput :: String
  }

type Defs = Map.Map L.Ident L.Def
type Settings = Set.Set Setting
data Setting = Dump | MeasureTime deriving (Eq, Ord, Enum)
data LineMode = SingleLine | MultiLine deriving (Eq)

instance Show Setting where
  show = \case
    Dump -> "dump"
    MeasureTime -> "time"
data SettingMode = Set | Unset deriving (Eq, Enum)

instance Show SettingMode where
  show = \case
    Set -> ":set"
    Unset -> ":unset"

parseSetting :: String -> Maybe Setting
parseSetting = \case
  "dump" -> Just Dump
  "time" -> Just MeasureTime
  _ -> Nothing

parseSettingMode :: String -> Maybe SettingMode
parseSettingMode = \case
  ":set" -> Just Set
  ":unset" -> Just Unset
  _ -> Nothing

parseSettingCommand :: String -> Either String (SettingMode, Setting)
parseSettingCommand command = case words command of
  [modeStr, settingStr] -> case parseSettingMode modeStr of
    Just mode -> case parseSetting settingStr of
      Just setting -> Right (mode, setting)
      Nothing -> Left $ "Unknown setting: " <> settingStr
    Nothing -> Left $ "Unknown command: " <> command
  [modeStr]
    | Just _ <- parseSettingMode modeStr -> Left "No setting specified"
  _ -> Left $ "Unknown command: " <> command
newtype Repl a = Repl
  { runRepl_ :: StateT ReplState (ReaderT AddColor IO) a
  }
  deriving
    ( Functor,
      Applicative,
      Monad,
      MonadIO,
      MonadState ReplState,
      MonadReader AddColor,
      Catch.MonadThrow,
      Catch.MonadCatch,
      Catch.MonadMask
    )

type AddColor = Term.Color -> String -> String

runRepl :: AddColor -> Repl a -> IO a
runRepl addColor =
  fmap fst
    . flip runReaderT addColor
    . flip runStateT (ReplState Map.empty Set.empty SingleLine 0 "")
    . runRepl_
run :: IO ()
run = do
  term <- Term.setupTermFromEnv
  let addColor =
        case Term.getCapability term $ Term.withForegroundColor @String of
          Just fc -> fc
          Nothing -> \_ s -> s
  runRepl addColor . H.runInputT settings $ do
    H.outputStrLn $ addColor promptColor "FiboLisp REPL"
    H.outputStrLn $ addColor infoColor "Press <TAB> to start"
    repl
  where
    settings =
      H.setComplete doCompletions $
        H.defaultSettings {H.historyFile = Just ".fibolisp"}
promptColor, printColor, outputColor, errorColor, infoColor :: Term.Color
promptColor = Term.Green
printColor = Term.White
outputColor = Term.Green
errorColor = Term.Red
infoColor = Term.Cyan
type Prompt = H.InputT Repl

repl :: Prompt ()
repl = do
  replLineMode .= SingleLine
  replIndent .= 0
  replSeenInput .= ""
  Catch.handle (\H.Interrupt -> repl) . H.withInterrupt $
    readInput >>= \case
      EndOfInput -> outputWithColor promptColor "Goodbye."
      input -> evalAndPrint input >> repl

outputWithColor :: Term.Color -> String -> Prompt ()
outputWithColor color text = do
  addColor <- getAddColor
  H.outputStrLn $ addColor color text

getAddColor :: Prompt AddColor
getAddColor = lift Reader.ask
type Lens' s a = Lens.Lens s s a a

replDefs :: Lens' ReplState Defs
replDefs = $(Lens.field '_replDefs)

replSettings :: Lens' ReplState Settings
replSettings = $(Lens.field '_replSettings)

replLineMode :: Lens' ReplState LineMode
replLineMode = $(Lens.field '_replLineMode)

replIndent :: Lens' ReplState Int
replIndent = $(Lens.field '_replIndent)

replSeenInput :: Lens' ReplState String
replSeenInput = $(Lens.field '_replSeenInput)

use :: (MonadTrans t, MonadState s m) => Lens' s a -> t m a
use l = lift . State.gets $ Lens.view l

(.=) :: (MonadTrans t, MonadState s m) => Lens' s a -> a -> t m ()
l .= a = lift . State.modify' $ Lens.set l a

(%=) :: (MonadTrans t, MonadState s m) => Lens' s a -> (a -> a) -> t m ()
l %= f = lift . State.modify' $ Lens.over l f
data Input
  = Setting (SettingMode, Setting)
  | Load FilePath
  | Source String
  | Help
  | Program L.Program
  | BadInputError String
  | EndOfInput
readInput :: Prompt Input
readInput = do
  addColor <- getAddColor
  lineMode <- use replLineMode
  prevIndent <- use replIndent

  let promptSym = case lineMode of SingleLine -> "λ"; _ -> "|"
      prompt = addColor promptColor $ promptSym <> "> "

  mInput <- H.getInputLineWithInitial prompt (replicate prevIndent ' ', "")
  let currentIndent = maybe 0 (length . takeWhile (== ' ')) mInput

  case trimStart . trimEnd <$> mInput of
    Nothing -> return EndOfInput
    Just input | null input -> do
      replIndent .= case lineMode of
        SingleLine -> prevIndent
        MultiLine -> currentIndent
      readInput
    Just input@(':' : _) -> parseCommand input
    Just input -> parseCode input currentIndent

trimStart :: String -> String
trimStart = dropWhile Char.isSpace

trimEnd :: String -> String
trimEnd = dropWhileEnd Char.isSpace
parseCommand :: String -> Prompt Input
parseCommand input
  | ":help" `isPrefixOf` input = return Help
  | ":load" `isPrefixOf` input =
      checkFilePath . trimStart . fromJust $ stripPrefix ":load" input
  | ":source" `isPrefixOf` input = do
      return . Source . trimStart . fromJust $ stripPrefix ":source" input
  | input == ":" = return $ BadInputError "No command specified"
  | otherwise = case parseSettingCommand input of
      Right setting -> return $ Setting setting
      Left err -> return $ BadInputError err

checkFilePath :: String -> Prompt Input
checkFilePath file
  | null file = return $ BadInputError "No file specified"
  | otherwise =
      isSafeFilePath file <&> \case
        True -> Load file
        False -> BadInputError $ "Cannot access file: " <> file

isSafeFilePath :: (MonadIO m) => FilePath -> m Bool
isSafeFilePath fp =
  liftIO $ isPrefixOf <$> getCurrentDirectory <*> canonicalizePath fp
parseCode :: String -> Int -> Prompt Input
parseCode currentInput indent = do
  seenInput <- use replSeenInput
  let input = seenInput <> " " <> currentInput
  case L.parse input of
    Left L.EndOfStreamError -> do
      replLineMode .= MultiLine
      replIndent .= indent
      replSeenInput .= input
      readInput
    Left err ->
      return $ BadInputError $ "ERROR: " <> displayException err
    Right program -> return $ Program program
evalAndPrint :: Input -> Prompt ()
evalAndPrint = \case
  EndOfInput -> return ()
  BadInputError err -> outputWithColor errorColor err
  Help -> H.outputStr helpMessage
  Setting (Set, setting) -> replSettings %= Set.insert setting
  Setting (Unset, setting) -> replSettings %= Set.delete setting
  Source ident -> showSource ident
  Load fp -> loadAndEvalFile fp
  Program program -> interpretAndPrint program
  where
    helpMessage =
      unlines
        [ "Available commands",
          ":set/:unset dump       Dumps the program AST",
          ":set/:unset time       Shows the program execution time",
          ":load <file>           Loads a source file",
          ":source <func_name>    Prints the source code of a function",
          ":help                  Shows this help"
        ]
showSource :: L.Ident -> Prompt ()
showSource ident = do
  defs <- use replDefs
  case Map.lookup ident defs of
    Just def -> outputWithColor infoColor $ L.prettyShowDef def
    Nothing -> case Map.lookup ident L.builtinFuncs of
      Just func -> outputWithColor infoColor $ show func
      Nothing ->
        outputWithColor errorColor $ "No such function: " <> ident
loadAndEvalFile :: FilePath -> Prompt ()
loadAndEvalFile fp =
  liftIO (doesFileExist fp) >>= \case
    False -> outputWithColor errorColor $ "No such file: " <> fp
    True -> Catch.handleAll outputError $ do
      code <- liftIO $ readFile fp
      outputWithColor infoColor $ "Loaded " <> fp
      case L.parse code of
        Left err -> outputError err
        Right program -> interpretAndPrint program

outputError :: (Exception e) => e -> Prompt ()
outputError err =
  outputWithColor errorColor $ "ERROR: " <> displayException err
interpretAndPrint :: L.Program -> Prompt ()
interpretAndPrint (L.Program pDefs exprs) =
  Catch.handleAll outputError $ do
    defs <- use replDefs
    settings <- use replSettings

    let defs' =
          foldl' (\ds d -> Map.insert (L.defName d) d ds) defs pDefs
        program = L.Program (Map.elems defs') exprs
    when (Dump `Set.member` settings) $
      outputWithColor infoColor (L.showProgram program)

    addColor <- getAddColor
    extPrint <- H.getExternalPrint

    (execTime, val) <- liftIO . measureElapsedTime $ do
      val <- L.interpret (extPrint . addColor printColor) program
      evaluate $ DS.force val

    case val of
      Left err -> outputError err
      Right v -> do
        let output = show v
        if null output
          then return ()
          else outputWithColor outputColor $ "=> " <> output

    when (MeasureTime `Set.member` settings) $
      outputWithColor infoColor $
        "(Execution time: " <> show execTime <> ")"

    replDefs .= defs'

measureElapsedTime :: IO a -> IO (NominalDiffTime, a)
measureElapsedTime f = do
  start <- getCurrentTime
  ret <- f
  end <- getCurrentTime
  return (diffUTCTime end start, ret)
doCompletions :: H.CompletionFunc Repl
doCompletions =
  fmap runIdentityT . H.completeWordWithPrev Nothing " " $ \leftRev word -> do
    defs <- use replDefs
    lineMode <- use replLineMode
    settings <- use replSettings
    let funcs = nub $ Map.keys defs <> Map.keys L.builtinFuncs
        vals = map show L.builtinVals
    case (word, lineMode) of
      ('(' : rest, _) ->
        pure
          [ H.Completion ('(' : hint) hint True
            | hint <- nub . sort $ L.carKeywords <> funcs,
              rest `isPrefixOf` hint
          ]
      (_, SingleLine) -> case word of
        "" | null leftRev ->
          pure [H.Completion "" s True | s <- commands <> funcs <> vals]
        ':' : _ | null leftRev ->
          pure [H.simpleCompletion c | c <- commands, word `isPrefixOf` c]
        _
          | "tes:" `isSuffixOf` leftRev ->
            pure
              [ H.simpleCompletion $ show s
                | s <- [Dump ..], s `notElem` settings, word `isPrefixOf` show s
              ]
          | "tesnu:" `isSuffixOf` leftRev ->
            pure
              [ H.simpleCompletion $ show s
                | s <- [Dump ..], s `elem` settings, word `isPrefixOf` show s
              ]
          | "daol:" `isSuffixOf` leftRev ->
            isSafeFilePath word >>= \case
              True -> H.listFiles word
              False -> pure []
          | "ecruos:" `isSuffixOf` leftRev ->
            pure
              [ H.simpleCompletion ident
                | ident <- funcs,
                  ident `Map.notMember` L.builtinFuncs,
                  word `isPrefixOf` ident
              ]
          | otherwise ->
            pure [H.simpleCompletion c | c <- funcs <> vals, word `isPrefixOf` c]
      _ -> pure []
  where
    commands = ":help" : ":load" : ":source" : map show [Set ..]
{
  "headers": {
    "Authorization": ["Bearer ${TOKEN}"]
  }
}
common --credential_helper=storage.googleapis.com=%workspace%/tools/credential-helper
bazel_dep(name = "rules_gcs", version = "1.0.0")
mkdir -p tools
wget -O tools/credential-helper https://raw.githubusercontent.com/tweag/rules_gcs/main/tools/credential-helper
chmod +x tools/credential-helper
common --credential_helper=storage.googleapis.com=%workspace%/tools/credential-helper
# optional setting to make rules_gcs more efficient
common --experimental_repository_cache_hardlinks
gcs_bucket = use_extension("@rules_gcs//gcs:extensions.bzl", "gcs_bucket")

gcs_bucket.from_file(
    name = "trainingdata",
    bucket = "my_org_assets",
    lockfile = "@//:gcs_lock.json",
)
gcs_file = use_repo_rule("@rules_gcs//gcs:repo_rules.bzl", "gcs_file")

gcs_file(
    name = "my_testdata",
    url = "gs://my_org_assets/testdata.bin",
    sha256 = "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855",
)
gcs_archive = use_repo_rule("@rules_gcs//gcs:repo_rules.bzl", "gcs_archive")

gcs_archive(
    name = "magic",
    url = "gs://my_org_code/libmagic.tar.gz",
    sha256 = "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855",
    build_file = "@//:magic.BUILD",
)
(id, name, email)
customers_id: int64[C]
customers_name: str[C]
customers_email: str[C]

dtype[DIM0, DIM1, ...]
SELECT c.name, c.email FROM customers c WHERE c.id = 1000

mask = customers_id == 1000
return (customers_name[mask], customers_email[mask])

C = dims(1)
c_id = customers_id[C]  # {C} => int64[]
c_name = customers_name[C]  # {C} => str[]
c_email = customers_email[C]  # {C} => str[]
c_mask = c_id == 1000  # {C} => bool[]

{DIM0, DIM1, ...} => dtype[DIM2, DIM3, ...]
torch.where(c_mask, c_name, ???)
C2, c2_name = torch.where(c_mask, c_name)  # {C2} => str[]
_C2, c2_email = torch.where(c_mask, c_email)  # {C2} => str[], n.b. C2 == _C2
return c2_name, c2_email

c_mask
torch.where
dyn
customers:  dyn[C, C_ATTR]
C = dims(1)
c = customers[C]  # {C} => dyn[C_ATTR]
C2, c2 = torch.where(c["id"] == 1000, c)  # {C2} => dyn[C_ATTR]
return c2[["name", "email"]].order(C2)  # dyn[C2, ["name", "email"]]

SELECT AVG(c.age) FROM customers c GROUP BY c.country;

torch.groupby
customers: dyn[C, C_ATTR]
customers_by_country = torch.groupby(customers, "country")  # dyn[COUNTRY, JC, C_ATTR]
COUNTRY, JC = dims(2)
c = customers_by_country[COUNTRY, JC]  # {COUNTRY, JC} => dyn[C_ATTR]
return c["age"].mean(JC).order(COUNTRY)  # f32[COUNTRY]

JC
SELECT o.id, c.name, c.email FROM orders o JOIN customers c ON o.customer_id = c.id

customers: dyn[C, C_ATTR]
orders: dyn[O, O_ATTR]
C, O = dims(2)
c = customers[C]  # {C} => dyn[C_ATTR]
o = orders[O]  # {O} => dyn[O_ATTR]
mask = o["customer_id"] == c["id"]  # {C, O} => bool[]
outer_product = torch.cat(o[["id"]], c[["name", "email"]])  # {C, O} => dyn[["id", "name", "email"]]
CO, co = torch.where(mask, outer_product)  # {CO} => dyn[["id", "name", "email"]]
return co.order(CO)  # dyn[C0, ["id", "name", "email"]]

      Blog
       |
       | What’s
       v
 Planet Haskell
       | 
       | Whatâ€™s
       v
haskell.pl-a.net (my site)
       |
       | Whatâ€™s
       v
  Your screen
      What the blog sees →       '’'
                                  |
                                  | UTF-8 encode (one character into three bytes)
                                  v
                             226 128 153
                                  |
                                  | ??? decode (not UTF-8)
                                  v
What Planet Haskell sees →   'â' '€' '™'
                                  |
                                  | UTF-8 encode
                                  v
                                (...)
                                  |
                                  | UTF-8 decode
                                  v
            What you see →   'â' '€' '™'
let windows1252_hack (c : Uchar.t) : int =
  let c = Uchar.to_int c in
  if      c = 0x20AC then 0x80
  else if c = 0x201A then 0x82
  else if c = 0x0192 then 0x83
  else if c = 0x201E then 0x84
  else if c = 0x2026 then 0x85
  else if c = 0x2020 then 0x86
  else if c = 0x2021 then 0x87
  else if c = 0x02C6 then 0x88
  else if c = 0x2030 then 0x89
  else if c = 0x0160 then 0x8A
  else if c = 0x2039 then 0x8B
  else if c = 0x0152 then 0x8C
  else if c = 0x017D then 0x8E
  else if c = 0x2018 then 0x91
  else if c = 0x2019 then 0x92
  else if c = 0x201C then 0x93
  else if c = 0x201D then 0x94
  else if c = 0x2022 then 0x95
  else if c = 0x2013 then 0x96
  else if c = 0x2014 then 0x97
  else if c = 0x02DC then 0x98
  else if c = 0x2122 then 0x99
  else if c = 0x0161 then 0x9A
  else if c = 0x203A then 0x9B
  else if c = 0x0153 then 0x9C
  else if c = 0x017E then 0x9E
  else if c = 0x0178 then 0x9F
  else c
module Coroutine ( YieldFn, spawn ) where
import Control.Monad ( join )
import Data.IORef ( IORef, newIORef, readIORef, writeIORef )

type YieldFn = IO () -> IO ()

yield :: IORef (IO ()) -> IO () -> IO ()
yield = writeIORef

resume :: IORef (IO ()) -> IO ()
resume = join . readIORef

terminate :: IORef (IO ()) -> IO ()
terminate yieldRef = writeIORef yieldRef (ioError $ userError "Subprocess completed")

spawn :: (YieldFn -> IO () -> IO ()) -> IO (IO ())
spawn process = do
    yieldRef <- newIORef undefined
    writeIORef yieldRef $ process (yield yieldRef) (terminate yieldRef)
    return (resume yieldRef)
process :: YieldFn -> Int -> IO () -> IO ()
process     _ 0 k = k
process yield i k = do
    putStrLn $ "Subprocess: " ++ show i
    yield $ process yield (i-1) k

example :: IO ()
example = do
    resume <- spawn $ \yield -> process yield 10
    forM_ [(1 :: Int) .. 10] $ \i -> do
        putStrLn $ "Main process: " ++ show i
        resume
    putStrLn "Main process done"
Main process: 1
Subprocess: 10
Main process: 2
Subprocess: 9
Main process: 3
Subprocess: 8
Main process: 4
Subprocess: 7
Main process: 5
Subprocess: 6
Main process: 6
Subprocess: 5
Main process: 7
Subprocess: 4
Main process: 8
Subprocess: 3
Main process: 9
Subprocess: 2
Main process: 10
Subprocess: 1
Main process done
module BatchedRebuildingQueue ( Queue, new, enqueue, dequeue ) where
import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef )

data Queue a = Queue {
    queueRef :: IORef ([a], [a])
}

new :: IO (Queue a)
new = do
    queueRef <- newIORef ([], [])
    return Queue { .. }

dequeue :: Queue a -> IO (Maybe a)
dequeue q@(Queue { .. }) = do
    (front, back) <- readIORef queueRef
    case front of
        (x:front') -> do
            writeIORef queueRef (front', back)
            return (Just x)
        [] -> case back of
                [] -> return Nothing
                _ -> rebuild q >> dequeue q

enqueue :: a -> Queue a -> IO ()
enqueue x (Queue { .. }) =
    modifyIORef queueRef (\(front, back) -> (front, x:back))

rebuild :: Queue a -> IO ()
rebuild (Queue { .. }) =
    modifyIORef queueRef (\([], back) -> (reverse back, []))
module GlobalRebuildingQueue ( Queue, new, dequeue, enqueue ) where
import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef, modifyIORef' )
import Coroutine ( YieldFn, spawn )

data Queue a = Queue {
    resume :: IO (),
    frontRef :: IORef [a],
    backRef :: IORef [a],
    frontCountRef :: IORef Int,
    backCountRef :: IORef Int
}

new :: IO (Queue a)
new = do
    frontRef <- newIORef []
    backRef <- newIORef []
    frontCountRef <- newIORef 0
    backCountRef <- newIORef 0
    resume <- spawn $ const . rebuild frontRef backRef frontCountRef backCountRef
    return Queue { .. }

dequeue :: Queue a -> IO (Maybe a)
dequeue q = do
    resume q
    front <- readIORef (frontRef q)
    case front of
        [] -> return Nothing
        (x:front') -> do
            modifyIORef' (frontCountRef q) pred
            writeIORef (frontRef q) front'
            return (Just x)

enqueue :: a -> Queue a -> IO ()
enqueue x q = do
    modifyIORef (backRef q) (x:)
    modifyIORef' (backCountRef q) succ
    resume q

rebuild :: IORef [a] -> IORef [a] -> IORef Int -> IORef Int -> YieldFn -> IO ()
rebuild frontRef backRef frontCountRef backCountRef yield = let k = go k in go k where
  go k = do
    frontCount <- readIORef frontCountRef
    backCount <- readIORef backCountRef
    if backCount > frontCount then do
        back <- readIORef backRef
        front <- readIORef frontRef
        writeIORef backRef []
        writeIORef backCountRef 0
        incrementalReverse back [] $ \rback ->
            incrementalReverse front [] $ \rfront ->
                incrementalRevAppend rfront rback 0 backCount k
      else do
        yield k

  incrementalReverse [] acc k = k acc
  incrementalReverse [x] acc k = k (x:acc)
  incrementalReverse (x:y:xs) acc k = yield $ incrementalReverse xs (y:x:acc) k

  incrementalRevAppend [] front !movedCount backCount' k = do
    writeIORef frontRef front
    writeIORef frontCountRef $! movedCount + backCount'
    yield k
  incrementalRevAppend (x:rfront) acc !movedCount backCount' k = do
    currentFrontCount <- readIORef frontCountRef
    if currentFrontCount <= movedCount then do
        -- This drop count should be bounded by a constant.
        writeIORef frontRef $! drop (movedCount - currentFrontCount) acc
        writeIORef frontCountRef $! currentFrontCount + backCount'
        yield k
      else if null rfront then
        incrementalRevAppend [] (x:acc) (movedCount + 1) backCount' k
      else
        yield $! incrementalRevAppend rfront (x:acc) (movedCount + 1) backCount' k
module DefunctionalizedQueue ( Queue, new, dequeue, enqueue ) where
import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef, modifyIORef' )

data Kont a r where
  IDLE :: Kont a ()
  REVERSE_STEP :: [a] -> [a] -> Kont a [a] -> Kont a ()
  REVERSE_FRONT :: [a] -> !Int -> Kont a [a]
  REV_APPEND_START :: [a] -> !Int -> Kont a [a]
  REV_APPEND_STEP :: [a] -> [a] -> !Int -> !Int -> Kont a ()

applyKont :: Queue a -> Kont a r -> r -> IO ()
applyKont q IDLE _ = rebuildLoop q
applyKont q (REVERSE_STEP xs acc k) _ = incrementalReverse q xs acc k
applyKont q (REVERSE_FRONT front backCount) rback =
    incrementalReverse q front [] $ REV_APPEND_START rback backCount
applyKont q (REV_APPEND_START rback backCount) rfront =
    incrementalRevAppend q rfront rback 0 backCount
applyKont q (REV_APPEND_STEP rfront acc movedCount backCount) _ =
    incrementalRevAppend q rfront acc movedCount backCount

rebuildLoop :: Queue a -> IO ()
rebuildLoop q@(Queue { .. }) = do
    frontCount <- readIORef frontCountRef
    backCount <- readIORef backCountRef
    if backCount > frontCount then do
        back <- readIORef backRef
        front <- readIORef frontRef
        writeIORef backRef []
        writeIORef backCountRef 0
        incrementalReverse q back [] $ REVERSE_FRONT front backCount
      else do
        writeIORef resumeRef IDLE

incrementalReverse :: Queue a -> [a] -> [a] -> Kont a [a] -> IO ()
incrementalReverse q [] acc k = applyKont q k acc
incrementalReverse q [x] acc k = applyKont q k (x:acc)
incrementalReverse q (x:y:xs) acc k = writeIORef (resumeRef q) $ REVERSE_STEP xs (y:x:acc) k

incrementalRevAppend :: Queue a -> [a] -> [a] -> Int -> Int -> IO ()
incrementalRevAppend (Queue { .. }) [] front !movedCount backCount' = do
    writeIORef frontRef front
    writeIORef frontCountRef $! movedCount + backCount'
    writeIORef resumeRef IDLE
incrementalRevAppend q@(Queue { .. }) (x:rfront) acc !movedCount backCount' = do
    currentFrontCount <- readIORef frontCountRef
    if currentFrontCount <= movedCount then do
        -- This drop count should be bounded by a constant.
        writeIORef frontRef $! drop (movedCount - currentFrontCount) acc
        writeIORef frontCountRef $! currentFrontCount + backCount'
        writeIORef resumeRef IDLE
      else if null rfront then
        incrementalRevAppend q [] (x:acc) (movedCount + 1) backCount'
      else
        writeIORef resumeRef $! REV_APPEND_STEP rfront (x:acc) (movedCount + 1) backCount'

resume :: Queue a -> IO ()
resume q = do
    kont <- readIORef (resumeRef q)
    applyKont q kont ()

data Queue a = Queue {
    resumeRef :: IORef (Kont a ()),
    frontRef :: IORef [a],
    backRef :: IORef [a],
    frontCountRef :: IORef Int,
    backCountRef :: IORef Int
}

new :: IO (Queue a)
new = do
    frontRef <- newIORef []
    backRef <- newIORef []
    frontCountRef <- newIORef 0
    backCountRef <- newIORef 0
    resumeRef <- newIORef IDLE
    return Queue { .. }

dequeue :: Queue a -> IO (Maybe a)
dequeue q  = do
    resume q
    front <- readIORef (frontRef q)
    case front of
        [] -> return Nothing
        (x:front') -> do
            modifyIORef' (frontCountRef q) pred
            writeIORef (frontRef q) front'
            return (Just x)

enqueue :: a -> Queue a -> IO ()
enqueue x q = do
    modifyIORef (backRef q) (x:)
    modifyIORef' (backCountRef q) succ
    resume q
module FunctionalQueue ( Queue, empty, dequeue, enqueue ) where

data Kont a r where
  IDLE :: Kont a ()
  REVERSE_STEP :: [a] -> [a] -> Kont a [a] -> Kont a ()
  REVERSE_FRONT :: [a] -> !Int -> Kont a [a]
  REV_APPEND_START :: [a] -> !Int -> Kont a [a]
  REV_APPEND_STEP :: [a] -> [a] -> !Int -> !Int -> Kont a ()

applyKont :: Queue a -> Kont a r -> r -> Queue a
applyKont q IDLE _ = rebuildLoop q
applyKont q (REVERSE_STEP xs acc k) _ = incrementalReverse q xs acc k
applyKont q (REVERSE_FRONT front backCount) rback =
    incrementalReverse q front [] $ REV_APPEND_START rback backCount
applyKont q (REV_APPEND_START rback backCount) rfront =
    incrementalRevAppend q rfront rback 0 backCount
applyKont q (REV_APPEND_STEP rfront acc movedCount backCount) _ =
    incrementalRevAppend q rfront acc movedCount backCount

rebuildLoop :: Queue a -> Queue a
rebuildLoop q@(Queue { .. }) =
    if backCount > frontCount then
        let q' = q { back = [], backCount = 0 } in
        incrementalReverse q' back [] $ REVERSE_FRONT front backCount
      else
        q { resumeKont = IDLE }

incrementalReverse :: Queue a -> [a] -> [a] -> Kont a [a] -> Queue a
incrementalReverse q [] acc k = applyKont q k acc
incrementalReverse q [x] acc k = applyKont q k (x:acc)
incrementalReverse q (x:y:xs) acc k = q { resumeKont = REVERSE_STEP xs (y:x:acc) k }

incrementalRevAppend :: Queue a -> [a] -> [a] -> Int -> Int -> Queue a
incrementalRevAppend q [] front' !movedCount backCount' =
    q { front = front', frontCount = movedCount + backCount', resumeKont = IDLE }
incrementalRevAppend q (x:rfront) acc !movedCount backCount' =
    if frontCount q <= movedCount then
        -- This drop count should be bounded by a constant.
        let !front = drop (movedCount - frontCount q) acc in
        q { front = front, frontCount = frontCount q + backCount', resumeKont = IDLE }
      else if null rfront then
        incrementalRevAppend q [] (x:acc) (movedCount + 1) backCount'
      else
        q { resumeKont = REV_APPEND_STEP rfront (x:acc) (movedCount + 1) backCount' }

resume :: Queue a -> Queue a
resume q = applyKont q (resumeKont q) ()

data Queue a = Queue {
    resumeKont :: !(Kont a ()),
    front :: [a],
    back :: [a],
    frontCount :: !Int,
    backCount :: !Int
}

empty :: Queue a
empty = Queue { resumeKont = IDLE, front = [], back = [], frontCount = 0, backCount = 0 }

dequeue :: Queue a -> (Maybe a, Queue a)
dequeue q =
    case front of
        [] -> (Nothing, q)
        (x:front') ->
            (Just x, q' { front = front', frontCount = frontCount - 1 })
  where q'@(Queue { .. }) = resume q

enqueue :: a -> Queue a -> Queue a
enqueue x q@(Queue { .. }) = resume (q { back = x:back, backCount = backCount + 1 })
module HoodMelvilleQueue (Queue, empty, dequeue, enqueue) where

data RotationState a
  = Idle
  | Reversing !Int [a] [a] [a] [a]
  | Appending !Int [a] [a]
  | Done [a]

data Queue a = Queue !Int [a] (RotationState a) !Int [a]

exec :: RotationState a -> RotationState a
exec (Reversing ok (x:f) f' (y:r) r') = Reversing (ok+1) f (x:f') r (y:r')
exec (Reversing ok [] f' [y] r') = Appending ok f' (y:r')
exec (Appending 0 f' r') = Done r'
exec (Appending ok (x:f') r') = Appending (ok-1) f' (x:r')
exec state = state

invalidate :: RotationState a -> RotationState a
invalidate (Reversing ok f f' r r') = Reversing (ok-1) f f' r r'
invalidate (Appending 0 f' (x:r')) = Done r'
invalidate (Appending ok f' r') = Appending (ok-1) f' r'
invalidate state = state

exec2 :: Int -> [a] -> RotationState a -> Int -> [a] -> Queue a
exec2 !lenf f state lenr r =
    case exec (exec state) of
        Done newf -> Queue lenf newf Idle lenr r
        newstate -> Queue lenf f newstate lenr r

check :: Int -> [a] -> RotationState a -> Int -> [a] -> Queue a
check !lenf f state !lenr r =
    if lenr <= lenf then exec2 lenf f state lenr r
    else let newstate = Reversing 0 f [] r []
         in exec2 (lenf+lenr) f newstate 0 []

empty :: Queue a
empty = Queue 0 [] Idle 0 []

dequeue :: Queue a -> (Maybe a, Queue a)
dequeue q@(Queue _ [] _ _ _) = (Nothing, q)
dequeue (Queue lenf (x:f') state lenr r) =
    let !q' = check (lenf-1) f' (invalidate state) lenr r in
    (Just x, q')

enqueue :: a -> Queue a -> Queue a
enqueue x (Queue lenf f state lenr r) = check lenf f state (lenr+1) (x:r)
module OkasakiQueue ( Queue, empty, dequeue, enqueue ) where

data Queue a = Queue [a] ![a] [a]

empty :: Queue a
empty = Queue [] [] []

dequeue :: Queue a -> (Maybe a, Queue a)
dequeue q@(Queue [] _ _) = (Nothing, q)
dequeue (Queue (x:f) r s) = (Just x, exec f r s)

rotate :: [a] -> [a] -> [a] -> [a]
rotate     [] (y: _) a = y:a
rotate (x:xs) (y:ys) a = x:rotate xs ys (y:a)

exec :: [a] -> [a] -> [a] -> Queue a
exec f !r (_:s) = Queue f r s
exec f !r [] = let f' = rotate f r [] in Queue f' [] f'

enqueue :: a -> Queue a -> Queue a
enqueue x (Queue f r s) = exec f (x:r) s 
module UnscheduledOkasakiQueue ( Queue, empty, dequeue, enqueue ) where

data Queue a = Queue [a] !Int [a] !Int

empty :: Queue a
empty = Queue [] 0 [] 0

dequeue :: Queue a -> (Maybe a, Queue a)
dequeue q@(Queue [] _ _ _) = (Nothing, q)
dequeue (Queue (x:f) lenf r lenr) = (Just x, exec f (lenf - 1) r lenr)

rotate :: [a] -> [a] -> [a] -> [a]
rotate     [] (y: _) a = y:a
rotate (x:xs) (y:ys) a = x:rotate xs ys (y:a)

exec :: [a] -> Int -> [a] -> Int -> Queue a
exec f !lenf !r !lenr | lenf >= lenr = Queue f lenf r lenr
exec f !lenf !r !lenr = let f' = rotate f r [] in Queue f' (lenf + lenr) [] 0

enqueue :: a -> Queue a -> Queue a
enqueue x (Queue f lenf r lenr) = exec f lenf (x:r) (lenr + 1) 

One chalk mark	$1.00
Knowing where to put it	$9,999.00
TOTAL	$10,000.00

Planet Haskell

January 17, 2025

Overview

Dependencies

Conclusions and future work

January 16, 2025

A producer-only world

Game theory and looters

Deterrence

Global scale

Peace through strength

Israel

Skin in the game

But what about the Palestinians?

January 15, 2025

About the Haskell Unfolder

January 13, 2025

Why incentives matter

Running a company

Moral hazard

Government moral hazards

Non-monetary competition

Bureaucracy

Government incentivized behavior

Conclusion

January 12, 2025

Some Context

Retrospective

January 09, 2025

Improving torch.compile

Improving torch.export

January 05, 2025

The Challenge

The Cellular Automaton

The Solution

The Zipper

The Comonad

The Array

The Stencil

Bonus Round: Simulation Visualization

January 04, 2025

December 24, 2024

Enable end-to-end C++ CPU/GPU Inference

Edge deployment

Pre-compiled kernels for eager mode

An exchange format across systems

December 23, 2024

Goals

Multisig

Software wallet

Hardware wallet

SLIP39

Comparison against goals

How-to guide

Conclusion

December 22, 2024

December 21, 2024

December 19, 2024

Create React App: A Historical Context

Performance Issues

Security Issues

Support Issues

Introducing Vite

Why Vite is Faster

1. Native ES Modules (ESM)

2. Efficient Hot Module Replacement (HMR)

3. Optimized Build Tooling

Practical Results

The Migration Process

Build Time

Dev Server Startup Time

HMR Update Time

Bundle Size

The Hidden Advantage: Reduced Context Switching

The Future of Vite is Bright

Conclusion

December 18, 2024

High living and melting ice cubes

The investment option

Michael (Midas) Mulligan