Planet Haskell

December 23, 2024 12:00 AM · not

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) 
    module Main (main) where

    import Diagrams.Backend.SVG.CmdLine
    import Diagrams.Prelude
    import PKD
    import TgraphExamples
    fig::Diagram B
    fig = someExample

    main :: IO ()
    main = mainWith fig
    data HalfTile rep 
      = LD rep -- Left Dart
      | RD rep -- Right Dart
      | LK rep -- Left Kite
      | RK rep -- Right Kite
      deriving (Show,Eq)
    type TileFace  = HalfTile (Vertex,Vertex,Vertex)
    type Vertex    = Int  -- must be positive
    makeTgraph :: [TileFace] -> Tgraph
    faces :: Tgraph -> [TileFace]
    fool :: Tgraph
    fool = makeTgraph [RD (1,2,3), LD (1,3,4)   -- right and left dart
                      ,LK (5,3,2), RK (5,2,7)   -- left and right kite
                      ,RK (5,4,3), LK (5,6,4)   -- right and left kite
                      ]
    foolFigure :: Diagram B
    foolFigure = draw fool
    foolFigure :: Diagram B
    foolFigure = labelled drawj fool
    newtype Tgraph = Tgraph [TileFace]
                     deriving (Show)
    makeUncheckedTgraph :: [TileFace] -> Tgraph
    checkedTgraph   :: [TileFace] -> Tgraph
    decompose :: Tgraph -> Tgraph
    force     :: Tgraph -> Tgraph
    compose   :: Tgraph -> Tgraph
    decompositions :: Tgraph -> [Tgraph]
    decompositions = iterate decompose
    tryCompose :: Tgraph -> Try Tgraph
    tryForce   :: Tgraph -> Try Tgraph
type Try a = Either String a
    runTry:: Try a -> a
    runTry = either error id
    force = runTry . tryForce
    compose = runTry . tryCompose
    originV :: TileFace -> Vertex -- the first vertex - red dot in figure 2
    oppV    :: TileFace -> Vertex -- the vertex at the opposite end of the join edge from the origin
    wingV   :: TileFace -> Vertex -- the vertex not on the join edge
    type Dedge = (Vertex,Vertex)
    internalEdges :: Tgraph -> [Dedge]
    graphBoundary :: Tgraph -> [Dedge]
    graphDedges :: Tgraph -> [Dedge]
    faceDedges :: TileFace -> [Dedge]
    joinE  :: TileFace -> Dedge  -- shown dotted in figure 2
    shortE :: TileFace -> Dedge  -- the non-join short edge
    longE  :: TileFace -> Dedge  -- the non-join long edge
    joinOfTile:: TileFace -> Dedge
    joinOfTile face = (originV face, oppV face)
    type Piece = HalfTile (V2 Double)
    type Patch = [Located Piece]
    drawPiece :: Piece -> Diagram B
    dashjPiece :: Piece -> Diagram B
    fillPieceDK :: Colour Double -> Colour Double -> Piece -> Diagram B
    type VertexLocMap = IntMap.IntMap (Point V2 Double)
    data VPatch = VPatch {vLocs :: VertexLocMap,  vpFaces::[TileFace]} deriving Show
    makeVP :: Tgraph -> VPatch
    labelled draw (rotate someAngle (makeVP g))
    alignXaxis :: (Vertex, Vertex) -> VPatch -> VPatch 
    labelled draw (alignXaxis (a,b) (makeVP g))
    draw   :: Drawable a => a -> Diagram B  -- draws non-join edges
    drawj  :: Drawable a => a -> Diagram B  -- as with draw but also draws dashed join edges
    fillDK :: Drawable a => Colour Double -> Colour Double -> a -> Diagram B -- fills with colours
    draw ::   (Drawable a, OKBackend b) =>
              a -> Diagram b
    drawj ::  (Drawable a, OKBackend) b) =>
              a -> Diagram b
    fillDK :: (Drawable a, OKBackend b) =>
              Colour Double -> Colour Double -> a -> Diagram b
    class Drawable a where
        drawWith :: (Piece -> Diagram B) -> a -> Diagram B

    draw = drawWith drawPiece
    drawj = drawWith dashjPiece
    fillDK clr1 clr2 = drawWith (fillPieceDK clr1 clr2)
    newPieceDraw :: Piece -> Diagram B
    newDraw :: Drawable a => a -> Diagram B
    newDraw = drawWith newPieceDraw
    class DrawableLabelled a where
        labelColourSize :: Colour Double -> Measure Double -> (Patch -> Diagram B) -> a -> Diagram B
    labelSize :: DrawableLabelled a => Measure Double -> (Patch -> Diagram B) -> a -> Diagram B
    labelSize = labelColourSize red

    labelled :: DrawableLabelled a => (Patch -> Diagram B) -> a -> Diagram B
    labelled = labelSize small
    smart :: (VPatch -> Diagram B) -> Tgraph -> Diagram B
    smart draw g
    smart (labelled draw) g
    smart (labelSize normal draw) g
    rotateBefore :: (VPatch -> a) -> Angle Double -> Tgraph -> a
    rotateBefore vpdraw angle = vpdraw . rotate angle . makeVP
    rotateBefore (labelled draw) (90@@deg) g
    rotate (90@@deg) (draw g)
    alignBefore :: (VPatch -> a) -> (Vertex,Vertex) -> Tgraph -> a
    alignBefore vpdraw (a,b) = vpdraw . alignXaxis (a,b) . makeVP
    alignBefore draw (a,b) g
    alignBefore (labelled draw) (a,b) g
    smart (labelled draw . rotate angle) g      -- WRONG
    smart (labelled draw . alignXaxis (a,b)) g  -- WRONG
    smartRotateBefore (labelled draw) angle g
    smartAlignBefore (labelled draw) (a,b) g
    smartRotateBefore :: (VPatch -> Diagram B) -> Angle Double -> Tgraph -> Diagram B
    smartAlignBefore  :: (VPatch -> Diagram B) -> (Vertex,Vertex) -> Tgraph -> Diagram B
    restrictSmart :: Tgraph -> (VPatch -> Diagram B) -> VPatch -> Diagram B
    drawForce :: Tgraph -> Diagram B
    drawPCompose  :: Tgraph -> Diagram B
    subVP :: VPatch -> [TileFace] -> VPatch
    restrictVP:: VPatch -> [TileFace] -> VPatch
    force :: Forcible a => a -> a
    tryForce :: Forcible a => a -> Try a
    stepForce :: Forcible a => Int -> a -> a
    tryStepForce  :: Forcible a => Int -> a -> Try a

    addHalfDart, addHalfKite :: Forcible a => Dedge -> a -> a
    tryAddHalfDart, tryAddHalfKite :: Forcible a => Dedge -> a -> Try a
    forceWith :: Forcible a => UpdateGenerator -> a -> a
    tryForceWith :: Forcible a => UpdateGenerator -> a -> Try a
    force = forceWith defaultAllUGen
    tryForce = tryForceWith defaultAllUGen
    wholeTiles :: Forcible a => a -> a
    wholeTiles = forceWith wholeTileUpdates
    type UpdateGenerator = BoundaryState -> [Dedge] -> Try UpdateMap
    type UpdateMap = Map.Map Dedge Update
    data Update = SafeUpdate TileFace 
                | UnsafeUpdate (Vertex -> TileFace)
    class Forcible a where
      tryFSOpWith :: UpdateGenerator -> (ForceState -> Try ForceState) -> a -> Try a
      tryChangeBoundaryWith :: UpdateGenerator -> (BoundaryState -> Try BoundaryChange) -> a -> Try a
      tryInitFSWith :: UpdateGenerator -> a -> Try ForceState
    tryFSOp :: Forcible a => (ForceState -> Try ForceState) -> a -> Try a
    tryFSOp = tryFSOpWith defaultAllUGen
    tryChangeBoundary :: Forcible a => (BoundaryState -> Try BoundaryChange) -> a -> Try a
    tryChangeBoundary = tryChangeBoundaryWith defaultAllUGen
    tryInitFS :: Forcible a => a -> Try ForceState
    tryInitFS = tryInitFSWith defaultAllUGen
    combo :: Dedge -> Tgraph -> Tgraph
    combo d = force . addHalfDart d . force . decompose
    force . addHalfDart d . force
    tryForce <=< tryAddHalfDart d <=< tryForce
    combo :: Dedge -> Tgraph -> Tgraph
    combo d = runTry . (tryForce <=< tryAddHalfDart d <=< tryForce) . decompose
    combo :: Dedge -> Tgraph -> Tgraph
    combo d = runTry . tryFSOp (tryForce <=< tryAddHalfDart d <=< tryForce) . decompose
    recalibratingForce :: Forcible a => a -> a
    tryRecalibratingForce :: Forcible a => a -> Try a
    recalibratingForce (decompositions kingGraph !!6)
    force (decompositions (force kingGraph) !!6)
    sameGraph :: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Bool
    tryRelabelToMatch :: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Try Tgraph
    tryFullUnion:: (Tgraph,Dedge) -> (Tgraph,Dedge) -> Try Tgraph
    commonFaces:: (Tgraph,Dedge) -> (Tgraph,Dedge) -> [TileFace]
    superForce:: Forcible a => a -> a
    forcedBoundaryECovering:: Tgraph -> [Tgraph]
    forcedBoundaryVCovering:: Tgraph -> [Tgraph]
    compForce:: Tgraph -> Tgraph      -- compose after forcing
    allCompForce:: Tgraph -> [Tgraph] -- iterated (compose after force) while not emptyTgraph
    maxCompForce:: Tgraph -> Tgraph   -- last item in allCompForce (or emptyTgraph)
    compForce = uncheckedCompose . force 
    data TrackedTgraph = TrackedTgraph
       { tgraph  :: Tgraph
       , tracked :: [[TileFace]] 
       } deriving Show
    decomposeTracked :: TrackedTgraph -> TrackedTgraph
    drawTrackedTgraph :: [VPatch -> Diagram B] -> TrackedTgraph -> Diagram B
    empire1, empire2 :: Tgraph -> TrackedTgraph

    drawEmpire :: TrackedTgraph -> Diagram B
import Probability.Distribution (Distribution, categorical, probabilities)

nashEquilibriumTo :: Integer -> Distribution Double Integer
nashEquilibriumTo m = categorical (zip allPs [1 ..])
  where
    allPs = go m 1 0 []
    go 1 pEqual pGreater ps = (/ (pEqual + pGreater)) <$> (pEqual : ps)
    go k pEqual pGreater ps =
      let pGreaterEqual = pEqual + pGreater
       in go
            (k - 1)
            (sqrt (pGreaterEqual * pGreaterEqual - pGreater * pGreater))
            pGreaterEqual
            (pEqual : ps)

main :: IO ()
main = print (probabilities (nashEquilibriumTo 100))
1 -> 0.4563109873079237
2 -> 0.24809127016999155
3 -> 0.1348844977362459
4 -> 7.333521940168612e-2
5 -> 3.987155303205954e-2
6 -> 2.1677725302500214e-2
7 -> 1.1785941067126387e-2
leastUnique :: (Ord a) => [a] -> Maybe a
leastUnique xs = listToMaybe [x | [x] <- group (sort xs)]
gameTo :: Integer -> Distribution Double (Maybe Integer)
gameTo m = do
  ns <- replicateM 3 (nashEquilibriumTo m)
  return (leastUnique ns)
main :: IO ()
main = print (probabilities (gameTo 100))
Nothing -> 0.11320677243374572
Just 1  -> 0.40465349320873445
Just 2  -> 0.22000565820506113
Just 3  -> 0.11961465909617276
Just 4  -> 6.503317590749513e-2
Just 5  -> 3.535782320137907e-2
Just 6  -> 1.9223659987298684e-2
Just 7  -> 1.0451692718822408e-2
expectedOutcomesTo :: Int -> Int -> Distribution Double Int -> [Double]
expectedOutcomesTo n m dist =
  [ probability (== Just i) $ leastUnique . (i :) <$> replicateM (n - 1) dist
    | i <- [1 .. m]
  ]
distFromConditionalStrategy :: [Double] -> Distribution Double Int
distFromConditionalStrategy = go 1
  where
    go i [] = pure i
    go i (q : qs) = do
      choice <- bernoulli q
      if choice then pure i else go (i + 1) qs
refine :: Int -> Int -> [Double] -> Distribution Double Int
refine n iters strategy
  | iters == 0 = equilibrium
  | otherwise =
      let ps = expectedOutcomesTo n m equilibrium
          delta = zipWith subtract (drop 1 ps) ps
          adjs = zipWith (+) strategy delta
       in refine n (iters - 1) adjs
  where
    m = length strategy + 1
    equilibrium = distFromConditionalStrategy strategy
main :: IO ()
main = do
  let n = 4
      m = 10
      d = refine n 10000 (replicate (m - 1) 0.3)
  print $ probabilities d
  print $ expectedOutcomesTo n m d
data GameState = GameState
  { dups :: Set Int,
    uniqs :: Set Int
  }
  deriving (Eq, Ord)
addToState :: Int -> GameState -> GameState
addToState n gs@(GameState dups uniqs)
  | Set.member n dups = gs
  | Set.member n uniqs = GameState (Set.insert n dups) (Set.delete n uniqs)
  | otherwise = GameState dups (Set.insert n uniqs)
stateDist :: Int -> Distribution Double Int -> Distribution Double GameState
stateDist n moves = go n (pure (GameState mempty mempty))
  where
    go 0 states = states
    go i states = go (i - 1) (simplify $ addToState <$> moves <*> states)
win :: Int -> GameState -> Bool
win n (GameState dups uniqs) =
  not (Set.member n dups) && maybe True (> n) (Set.lookupMin uniqs)
expectedOutcomesTo :: Int -> Int -> Distribution Double Int -> [Double]
expectedOutcomesTo n m dist = [probability (win i) states | i <- [1 .. m]]
  where
    states = stateDist (n - 1) dist

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

Planet Haskell

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

Michael (Crappy Investor) Snoyman

Normal people shouldn’t invest

Option 4: deflation

Further reading

December 17, 2024

What is Nostr? Why Nostr?

Protocol overview

Getting started

Lightning wallet: coinos

Web client: YakiHonne

NIP-05 Nostr address

Signer

Relays

Mobile

Introductions

My experience

December 16, 2024

GHC 9.12.1 is now available

Zubin Duggal - 2024-12-16

December 13, 2024

Sponsorship

Team

GHC Releases

Cabal

HLS

GHC

Exception backtraces

Frontend

SIMD in the NCG backend

LLVM backend

RISC-V backend

Object code determinism

Compiler performance

Runtime system

Documentation

Codebase improvements

GHC API

Libraries

Profiling

Build system

Testsuite

CI

December 12, 2024

Stackage LTS 23 has been released

Stackage Nightly updated to ghc-9.10.1