Skip to content

Instantly share code, notes, and snippets.

View ChrisPenner's full-sized avatar
:bowtie:
Happily Hacking

Chris Penner ChrisPenner

:bowtie:
Happily Hacking
View GitHub Profile
@ChrisPenner
ChrisPenner / DynamicBFS.hs
Created May 12, 2022 18:38
Effectful, lazy, BFS using LogicT.
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module BFS where
import Control.Applicative
import Control.Monad.Logic
import Control.Monad.Reader
@ChrisPenner
ChrisPenner / Cookies.hs
Created March 18, 2022 02:49
Cookie handling in Servant.
import Data.Function ((&))
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as Text
import GHC.TypeLits (KnownSymbol, Nat, Symbol, symbolVal)
import Servant
import qualified Web.Cookie as Cookie
-- | Allows deserializing a single cookie in a servant route.
@ChrisPenner
ChrisPenner / FreeProfunctor.hs
Created March 20, 2021 15:13
'Progressive' Free profunctors!
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
module Data.Profunctor.Free where
import Data.Profunctor
import Control.Category (Category, (>>>))
data IsCat =
HasCategory
@ChrisPenner
ChrisPenner / RequireTypeAp.hs
Created November 18, 2020 18:19
A hack to require type applications, even when not necessary
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
-- Don't export this, it's just to make it so the type family *could* have a different
@ChrisPenner
ChrisPenner / SemiRepresentable.hs
Created October 12, 2020 04:46
SemiRepresentable
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
module SemiRepresentable where
import qualified Data.Map as M
import Numeric.Natural
import qualified Data.Set as S
import Data.These
-- Bind an async to be cancelled when the current computation ends.
bindAsync :: IO a -> ContT r IO ()
bindAsync m = do
ContT $ \cc -> do
withAsync m . const $ cc ()
-- Use bindAsync to auto-cancel the thread when the containing computation finishes
testBoundAsync :: ContT r IO ()
testBoundAsync = do
bindAsync . forever $ print "can you hear me now?"
@ChrisPenner
ChrisPenner / MapF.hs
Last active September 20, 2020 19:36
MapF
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
module MyMap where
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE RankNTypes #-}
module Recurser where
import Control.Lens
import Data.Monoid
import Data.Foldable
import Data.Functor.Contravariant
@ChrisPenner
ChrisPenner / haddock-up.sh
Created June 24, 2020 15:17
Fix Haddock Docs
#!/bin/bash
# Adapted from script by Dimitri Sabadie <[email protected]>
dist=$(stack path --dist-dir --stack-yaml ./stack.yaml)
packagename=$(awk '/^name:\s*(.*)/{ print $2 }' ./*.cabal)
packageversion=$(awk '/^version:\s*(.*)/{ print $2 }' ./*.cabal)
echo -e "\033[1;36mGenerating documentation for $packagename-$packageversion\033[0m"
@ChrisPenner
ChrisPenner / TextOptics.hs
Created April 19, 2020 21:53
Optics for doing some text manipulation
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE FlexibleContexts #-}
module Lib where
import Control.Lens
import Control.Applicative
import qualified Data.Text as T