Skip to content

Instantly share code, notes, and snippets.

View fizruk's full-sized avatar
♾️

Nikolai Kudasov fizruk

♾️
View GitHub Profile
data Description (sym :: Symbol)
instance (KnownSymbol sym, HasSwagger api) => HasSwagger (Description sym :> api) where
toSwagger _ = toSwagger (Proxy :: Proxy api)
& allOperations.description ?~ desc
where
desc = symbolVal (Proxy :: Proxy sym)
{-# LANGUAGE ScopedTypeVariables #-}
import Control.Lens
import Data.Typeable
import qualified Data.Text as Text
instance {-# OVERLAPPING #-} (Typeable a, ToSchema a) => ToSchema (Either WalletError a) where
declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
& mapped.name ?~ Text.pack ("Either WalletError " ++ show (typeOf (undefined :: a)))
import Data.Monoid
newtype F a b = F (a -> b)
deriving (Functor)
instance Monoid b => Monoid (F a b) where
mempty = F mempty
mappend (F f) (F g) = F (f <> g)
instance (Bounded a, Enum a) => Foldable (F a) where
@fizruk
fizruk / A.hs
Last active December 19, 2016 12:11
An Applicative with an explicit Pure
import Control.Applicative
import Data.Functor.Apply
-- A wrapper for an applicative functor with an explicit pure constructor.
data A f a
= A (f a) -- applicative container
| P a -- explicit "pure" constructor
deriving (Show, Eq, Functor, Foldable)
instance Apply f => Applicative (A f) where
@fizruk
fizruk / upload_haddocks.sh
Created August 6, 2016 16:22
Build and upload haddocks for multi-package Stack project to custom server.
#!/bin/bash
set -e
# Run this script from top-level multi-package Stack project.
# It will build haddock documentation for every package and
# upload it over SSH to $SERVER:$SERVER_HADDOCK_PATH
# Script accepts 2 arguments: BRANCH and HADDOCK_PATH
# HADDOCK_PATH is where haddocks are served.
# BRANCH is an extra tag for this particular docs, I usually use Git branch.
@fizruk
fizruk / ApiClient.hs
Created July 22, 2016 22:04
Servant Client structure example (for servant-0.8)
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeOperators #-}
module ApiClient where
import Data.Aeson
import Data.Proxy
import Network.HTTP.Client (Manager)
import Servant.API
@fizruk
fizruk / Base64UUID.hs
Last active March 4, 2017 09:41
Base64 encoded UUIDs safe for URLs (YouTube style)
import Data.Char (chr, ord)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Base64 as Base64
import qualified Data.UUID as UUID
-- | Base64 encoded UUID (YouTube style for safe usage in URLs).
newtype Base64UUID = Base64UUID UUID deriving (Show, Eq)
@fizruk
fizruk / snapshot-ghc8.yaml
Last active March 4, 2016 21:11
Stack config with GHC 8.0.1-rc2 on Mac OS X.
compiler: ghc-8.0.0.20160204
setup-info:
ghc:
macosx:
8.0.0.20160204:
url: "http://downloads.haskell.org/~ghc/8.0.1-rc2/ghc-8.0.0.20160204-x86_64-apple-darwin.tar.xz"
packages:
- base-orphans-0.5.1
@fizruk
fizruk / Nub.hs
Created February 7, 2016 13:18
Incredibly slow type-level Nub
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Nub where
import Data.Proxy
import Data.Type.Bool
@fizruk
fizruk / GitHubGistAPI.hs
Created February 4, 2016 23:30
GitHub API v3 — Gists (partial)
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
module GitHub where
import Control.Lens
import Data.Aeson
import Data.Aeson.Types (camelTo)