├── README.md ├── lazy-reverse ├── README.md ├── .stack │ ├── stack.sqlite3.pantry-write-lock │ ├── pantry │ │ ├── pantry.sqlite3.pantry-write-lock │ │ └── pantry.sqlite3 │ ├── stack.sqlite3 │ └── config.yaml ├── Setup.hs ├── __pycache__ │ └── run.cpython-310.pyc ├── CHANGELOG.md ├── stack.yaml.lock ├── lazy-reverse.cabal ├── LICENSE ├── src │ └── Main.hs └── stack.yaml ├── mineunifier ├── Setup.hs ├── stack.yaml.lock ├── src │ └── Mineunifier │ │ ├── Util.hs │ │ ├── IO.hs │ │ ├── Core.hs │ │ └── Test.hs ├── mineunifier.cabal ├── LICENSE └── stack.yaml ├── poly-traversable ├── stack.yaml ├── poly-traversable.cabal └── src │ ├── FunDep.hs │ └── Main.hs ├── validation-leak ├── Setup.hs ├── fine.sh ├── leak.sh ├── src │ ├── Except.hs │ ├── Main.hs │ ├── Leak.hs │ └── Fine.hs ├── validation-leak.cabal ├── LICENSE ├── stack.yaml └── README.md ├── a-law-breaking-hack ├── Setup.hs ├── stack.yaml.lock ├── a-law-breaking-hack.cabal ├── LICENSE ├── src │ └── Main.hs ├── stack.yaml └── README.md ├── custom-warning-hack ├── Setup.hs ├── stack.yaml.lock ├── custom-warning-hack.cabal ├── src │ └── Main.hs ├── LICENSE ├── stack.yaml └── README.md ├── has-lens-done-right ├── stack.yaml ├── stack.yaml.lock ├── has-lens-done-right.cabal └── src │ ├── Main.hs │ ├── TF.hs │ └── FunDep.hs ├── better-syntax-for-eDSLs ├── Setup.hs ├── src │ ├── Main.hs │ ├── Common.hs │ ├── Unscoped.hs │ └── Scoped.hs ├── stack.yaml.lock ├── better-syntax-for-eDSLs.cabal ├── LICENSE └── stack.yaml ├── generalizing-unliftio ├── Setup.hs ├── src │ ├── Main.hs │ ├── SomeAction.hs │ ├── UnliftIO.hs │ ├── Peel.hs │ ├── Unlift.hs │ └── UnliftPeel.hs ├── stack.yaml.lock ├── generalizing-unliftio.cabal ├── LICENSE └── stack.yaml ├── things-you-should-avoid ├── Setup.hs ├── stack.yaml.lock ├── things-you-should-avoid.cabal ├── LICENSE ├── src │ └── Main.hs ├── stack.yaml └── README.md ├── avoid-overlapping-recursive ├── stack.yaml ├── avoid-overlapping-recursive.cabal └── src │ ├── TF.hs │ ├── Main.hs │ ├── BackwardsTF.hs │ └── Bonus.hs ├── custom-type-equality-errors ├── Setup.hs ├── stack.yaml ├── custom-type-equality-errors.cabal ├── stack.yaml.lock ├── LICENSE ├── src │ └── Main.hs └── README.md ├── trouble-in-paradise-fibonacci ├── Setup.hs ├── stack.yaml ├── stack.yaml.lock ├── trouble-in-paradise-fibonacci.cabal ├── LICENSE └── src │ └── Main.hs ├── better-counterexample-minimization ├── Setup.hs ├── CHANGELOG.md ├── stack.yaml.lock ├── better-counterexample-minimization.cabal ├── LICENSE ├── stack.yaml └── src │ └── Main.hs ├── poly-type-of-saga ├── part1-try-unify │ ├── Setup.hs │ ├── stack.yaml.lock │ ├── part1-try-unify.cabal │ ├── LICENSE │ ├── stack.yaml │ └── src │ │ └── Main.hs └── part2-enumerate-type-vars │ ├── Setup.hs │ ├── stack.yaml.lock │ ├── part2-enumerate-type-vars.cabal │ ├── src │ └── TypeToString.hs │ ├── LICENSE │ └── stack.yaml ├── exhaustive-unordered-pattern-matching ├── Setup.hs ├── CHANGELOG.md ├── stack.yaml.lock ├── src │ └── Main.hs ├── exhaustive-unordered-pattern-matching.cabal ├── LICENSE ├── stack.yaml └── README.md ├── hierarchical-free-monads-mostly-pointless ├── stack.yaml ├── src │ ├── Main.hs │ ├── FT.hs │ ├── HFT.hs │ └── HFM.hs ├── stack.yaml.lock └── hierarchical-free-monads-mostly-pointless.cabal ├── compilation-surviving-proofs └── compilation-surviving-proofs.agda-lib ├── unordered-effects ├── stack.yaml └── unordered-effects.cabal ├── extensible-monadic-lenses ├── stack.yaml └── extensible-monadic-lenses.cabal ├── haskell-emacs-jump-to-definition └── code.el ├── restore-interruptible └── README.md └── denotational-approximations └── README.md /README.md: -------------------------------------------------------------------------------- 1 | # A Haskell blog 2 | -------------------------------------------------------------------------------- /lazy-reverse/README.md: -------------------------------------------------------------------------------- 1 | # lazy-reverse 2 | -------------------------------------------------------------------------------- /lazy-reverse/.stack/stack.sqlite3.pantry-write-lock: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /lazy-reverse/.stack/pantry/pantry.sqlite3.pantry-write-lock: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /lazy-reverse/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /mineunifier/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /poly-traversable/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-11.3 2 | 3 | packages: 4 | - . 5 | -------------------------------------------------------------------------------- /validation-leak/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /a-law-breaking-hack/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /custom-warning-hack/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /has-lens-done-right/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-13.15 2 | 3 | packages: 4 | - . 5 | -------------------------------------------------------------------------------- /validation-leak/fine.sh: -------------------------------------------------------------------------------- 1 | stack build 2 | stack exec -- validation-leak "fine" 3 | -------------------------------------------------------------------------------- /validation-leak/leak.sh: -------------------------------------------------------------------------------- 1 | stack build 2 | stack exec -- validation-leak "leak" 3 | -------------------------------------------------------------------------------- /better-syntax-for-eDSLs/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /generalizing-unliftio/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /things-you-should-avoid/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /avoid-overlapping-recursive/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-13.15 2 | 3 | packages: 4 | - . 5 | -------------------------------------------------------------------------------- /custom-type-equality-errors/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /trouble-in-paradise-fibonacci/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /better-counterexample-minimization/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /generalizing-unliftio/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | main :: IO () 4 | main = mempty 5 | -------------------------------------------------------------------------------- /poly-type-of-saga/part1-try-unify/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /better-syntax-for-eDSLs/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | main :: IO () 4 | main = pure () 5 | -------------------------------------------------------------------------------- /exhaustive-unordered-pattern-matching/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /hierarchical-free-monads-mostly-pointless/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-13.26 2 | 3 | packages: 4 | - . 5 | -------------------------------------------------------------------------------- /poly-type-of-saga/part2-enumerate-type-vars/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /compilation-surviving-proofs/compilation-surviving-proofs.agda-lib: -------------------------------------------------------------------------------- 1 | depend: standard-library 2 | include: . 3 | -------------------------------------------------------------------------------- /hierarchical-free-monads-mostly-pointless/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | main :: IO () 4 | main = mempty 5 | -------------------------------------------------------------------------------- /unordered-effects/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-13.15 2 | 3 | packages: 4 | - . 5 | 6 | extra-deps: 7 | - fastsum-0.1.1.1 8 | -------------------------------------------------------------------------------- /extensible-monadic-lenses/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-11.3 2 | 3 | packages: 4 | - . 5 | 6 | extra-deps: 7 | - monad-var-0.2.1.0 -------------------------------------------------------------------------------- /lazy-reverse/.stack/stack.sqlite3: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/effectfully-ou/sketches/HEAD/lazy-reverse/.stack/stack.sqlite3 -------------------------------------------------------------------------------- /trouble-in-paradise-fibonacci/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-16.27 2 | 3 | packages: 4 | - . 5 | 6 | extra-deps: 7 | - nothunks-0.1.2 8 | -------------------------------------------------------------------------------- /custom-type-equality-errors/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-17.2 2 | 3 | packages: 4 | - . 5 | 6 | extra-deps: 7 | - type-level-sets-0.8.9.0 8 | -------------------------------------------------------------------------------- /lazy-reverse/.stack/pantry/pantry.sqlite3: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/effectfully-ou/sketches/HEAD/lazy-reverse/.stack/pantry/pantry.sqlite3 -------------------------------------------------------------------------------- /lazy-reverse/__pycache__/run.cpython-310.pyc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/effectfully-ou/sketches/HEAD/lazy-reverse/__pycache__/run.cpython-310.pyc -------------------------------------------------------------------------------- /validation-leak/src/Except.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | module Except where 3 | 4 | class Except f e | f -> e where 5 | throw :: e -> f a 6 | -------------------------------------------------------------------------------- /generalizing-unliftio/src/SomeAction.hs: -------------------------------------------------------------------------------- 1 | module SomeAction where 2 | 3 | import Control.Monad.IO.Class 4 | 5 | printM :: (MonadIO m, Show a) => a -> m () 6 | printM = liftIO . print 7 | 8 | class MonadIO m => SomeAction m where 9 | someAction :: m () 10 | someAction = liftIO $ putStrLn "performed some action" 11 | -------------------------------------------------------------------------------- /lazy-reverse/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog for `lazy-reverse` 2 | 3 | All notable changes to this project will be documented in this file. 4 | 5 | The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), 6 | and this project adheres to the 7 | [Haskell Package Versioning Policy](https://pvp.haskell.org/). 8 | 9 | ## Unreleased 10 | 11 | ## 0.1.0.0 - YYYY-MM-DD 12 | -------------------------------------------------------------------------------- /better-counterexample-minimization/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog for `better-counterexample-minimization` 2 | 3 | All notable changes to this project will be documented in this file. 4 | 5 | The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), 6 | and this project adheres to the 7 | [Haskell Package Versioning Policy](https://pvp.haskell.org/). 8 | 9 | ## Unreleased 10 | 11 | ## 0.1.0.0 - YYYY-MM-DD 12 | -------------------------------------------------------------------------------- /exhaustive-unordered-pattern-matching/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog for `exhaustive-unordered-pattern-matching` 2 | 3 | All notable changes to this project will be documented in this file. 4 | 5 | The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), 6 | and this project adheres to the 7 | [Haskell Package Versioning Policy](https://pvp.haskell.org/). 8 | 9 | ## Unreleased 10 | 11 | ## 0.1.0.0 - YYYY-MM-DD 12 | -------------------------------------------------------------------------------- /extensible-monadic-lenses/extensible-monadic-lenses.cabal: -------------------------------------------------------------------------------- 1 | name: extensible-monadic-lenses 2 | version: 0.1.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | extra-source-files: README.md 6 | 7 | executable extensible-monadic-lenses 8 | hs-source-dirs: src 9 | main-is: Main.hs 10 | default-language: Haskell2010 11 | build-depends: base >= 4.7 && < 5, 12 | profunctors, 13 | monad-var 14 | -------------------------------------------------------------------------------- /mineunifier/stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 586103 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/19.yaml 11 | sha256: 32716534fff554b7f90762130fdb985cabf29f157758934dd1c8f3892a646430 12 | original: lts-18.19 13 | -------------------------------------------------------------------------------- /custom-warning-hack/stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 563099 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/2.yaml 11 | sha256: 92b1a17e31d0a978fca4bf270305d4d1dd8092271bf60eafbc9349c890854026 12 | original: lts-17.2 13 | -------------------------------------------------------------------------------- /lazy-reverse/stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/topics/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | sha256: 4ef79c30b9efcf07335cb3de532983a7ac4c5a4180bc17f6212a86b09ce2ff75 10 | size: 680777 11 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/23/7.yaml 12 | original: lts-23.7 13 | -------------------------------------------------------------------------------- /a-law-breaking-hack/stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 499889 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/26.yaml 11 | sha256: ecb02ee16829df8d7219e7d7fe6c310819820bf335b0b9534bce84d3ea896684 12 | original: lts-13.26 13 | -------------------------------------------------------------------------------- /better-syntax-for-eDSLs/src/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE StandaloneKindSignatures #-} 3 | 4 | module Common where 5 | 6 | import GHC.TypeLits 7 | import Data.Kind 8 | 9 | data Term 10 | = Var String 11 | | Lam String Term 12 | | App Term Term 13 | deriving (Show) 14 | 15 | type Prefix :: Symbol -> Type 16 | data Prefix prefix = Prefix 17 | 18 | var :: Prefix "var" 19 | var = Prefix 20 | 21 | lam :: Prefix "lam" 22 | lam = Prefix 23 | 24 | app :: Term -> Term -> Term 25 | app = App 26 | -------------------------------------------------------------------------------- /generalizing-unliftio/stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 563099 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/2.yaml 11 | sha256: 92b1a17e31d0a978fca4bf270305d4d1dd8092271bf60eafbc9349c890854026 12 | original: lts-17.2 13 | -------------------------------------------------------------------------------- /has-lens-done-right/stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 497089 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/15.yaml 11 | sha256: 62c27bdce4a1b7cae3d2f6c29d1d0ae49d75bbbeb7ac6d7e6783d964562c3675 12 | original: lts-13.15 13 | -------------------------------------------------------------------------------- /avoid-overlapping-recursive/avoid-overlapping-recursive.cabal: -------------------------------------------------------------------------------- 1 | name: avoid-overlapping-recursive 2 | version: 0.1.0.0 3 | cabal-version: >=1.10 4 | extra-source-files: README.md 5 | build-type: Simple 6 | 7 | executable poly-traversable 8 | hs-source-dirs: src 9 | main-is: Main.hs 10 | default-language: Haskell2010 11 | other-modules: Bonus 12 | BackwardsTF 13 | TF 14 | build-depends: base >= 4.7 && < 5 15 | -------------------------------------------------------------------------------- /things-you-should-avoid/stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 499889 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/26.yaml 11 | sha256: ecb02ee16829df8d7219e7d7fe6c310819820bf335b0b9534bce84d3ea896684 12 | original: lts-13.26 13 | -------------------------------------------------------------------------------- /better-counterexample-minimization/stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | sha256: 4ef79c30b9efcf07335cb3de532983a7ac4c5a4180bc17f6212a86b09ce2ff75 10 | size: 680777 11 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/23/7.yaml 12 | original: lts-23.7 13 | -------------------------------------------------------------------------------- /poly-traversable/poly-traversable.cabal: -------------------------------------------------------------------------------- 1 | name: poly-traversable 2 | version: 0.1.0.0 3 | cabal-version: >=1.10 4 | extra-source-files: README.md 5 | build-type: Simple 6 | 7 | executable poly-traversable 8 | hs-source-dirs: src 9 | main-is: Main.hs 10 | other-modules: FunDep 11 | default-language: Haskell2010 12 | build-depends: base >= 4.7 && < 5, 13 | containers, 14 | bytestring, 15 | text 16 | -------------------------------------------------------------------------------- /hierarchical-free-monads-mostly-pointless/stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 499889 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/26.yaml 11 | sha256: ecb02ee16829df8d7219e7d7fe6c310819820bf335b0b9534bce84d3ea896684 12 | original: lts-13.26 13 | -------------------------------------------------------------------------------- /poly-type-of-saga/part1-try-unify/stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 520865 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/8/17.yaml 11 | sha256: 700c74c4e263f34ccb9937561eee52454dd435ec96119e2eef2d50adc4fd58a8 12 | original: nightly-2020-08-17 13 | -------------------------------------------------------------------------------- /poly-type-of-saga/part2-enumerate-type-vars/stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 520865 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/8/17.yaml 11 | sha256: 700c74c4e263f34ccb9937561eee52454dd435ec96119e2eef2d50adc4fd58a8 12 | original: nightly-2020-08-17 13 | -------------------------------------------------------------------------------- /has-lens-done-right/has-lens-done-right.cabal: -------------------------------------------------------------------------------- 1 | name: has-lens-done-right 2 | version: 0.1.0.0 3 | cabal-version: >=1.10 4 | extra-source-files: README.md 5 | build-type: Simple 6 | 7 | executable has-lens-done-right 8 | hs-source-dirs: src 9 | main-is: Main.hs 10 | default-language: Haskell2010 11 | other-modules: FunDep 12 | TF 13 | build-depends: base >= 4.7 && < 5, 14 | ghc-prim, 15 | tagged, 16 | lens 17 | -------------------------------------------------------------------------------- /validation-leak/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module Main where 3 | 4 | import System.Environment 5 | import Except 6 | import qualified Leak 7 | import qualified Fine 8 | 9 | multifail :: (Except f [Int], Applicative f) => f () 10 | multifail = go 1000000 where 11 | go 0 = pure () 12 | go n = throw [n] *> go (n - 1) 13 | 14 | main :: IO () 15 | main = do 16 | args <- getArgs 17 | print . sum $ case args of 18 | ["leak"] -> let Leak.Failure ns = multifail in ns 19 | ["fine"] -> let Fine.Failure ns = multifail in ns 20 | _ -> fail "don't play with me" 21 | -------------------------------------------------------------------------------- /unordered-effects/unordered-effects.cabal: -------------------------------------------------------------------------------- 1 | name: unordered-effects 2 | version: 0.1.0.0 3 | cabal-version: >=1.10 4 | extra-source-files: README.md 5 | build-type: Simple 6 | 7 | executable unordered-effects 8 | hs-source-dirs: src 9 | main-is: Main.hs 10 | default-language: Haskell2010 11 | other-modules: HO 12 | build-depends: base >= 4.7 && < 5, 13 | transformers, 14 | mtl, 15 | mmorph, 16 | lens, 17 | fastsum 18 | -------------------------------------------------------------------------------- /better-syntax-for-eDSLs/stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | sha256: 4be1ca5d31689b524a7f0f17a439bbe9136465213edc498e9a395899a670f2aa 10 | size: 718486 11 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/22.yaml 12 | original: 13 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/22.yaml 14 | -------------------------------------------------------------------------------- /exhaustive-unordered-pattern-matching/stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | sha256: 4be1ca5d31689b524a7f0f17a439bbe9136465213edc498e9a395899a670f2aa 10 | size: 718486 11 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/22.yaml 12 | original: 13 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/22.yaml 14 | -------------------------------------------------------------------------------- /hierarchical-free-monads-mostly-pointless/hierarchical-free-monads-mostly-pointless.cabal: -------------------------------------------------------------------------------- 1 | name: hierarchical-free-monads-mostly-pointless 2 | version: 0.1.0.0 3 | cabal-version: >=1.10 4 | extra-source-files: README.md 5 | build-type: Simple 6 | 7 | executable hierarchical-free-monads-mostly-pointless 8 | hs-source-dirs: src 9 | main-is: Main.hs 10 | default-language: Haskell2010 11 | other-modules: HFM 12 | FT 13 | HFT 14 | build-depends: base >= 4.7 && < 5, 15 | free, 16 | random 17 | -------------------------------------------------------------------------------- /validation-leak/src/Leak.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} 2 | module Leak where 3 | 4 | import Data.Semigroup 5 | import Except 6 | 7 | data Validation e a 8 | = Failure e 9 | | Success a 10 | 11 | instance Functor (Validation e) where 12 | fmap f (Failure e) = Failure e 13 | fmap f (Success x) = Success (f x) 14 | 15 | instance Semigroup e => Applicative (Validation e) where 16 | pure = Success 17 | 18 | Failure e1 <*> Failure e2 = Failure (e1 <> e2) 19 | Failure e <*> Success _ = Failure e 20 | Success _ <*> Failure e = Failure e 21 | Success f <*> Success x = Success (f x) 22 | 23 | instance Except (Validation e) e where 24 | throw = Failure 25 | -------------------------------------------------------------------------------- /validation-leak/src/Fine.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} 2 | module Fine where 3 | 4 | import Data.Monoid 5 | import Except 6 | 7 | data Validation e a 8 | = Failure e 9 | | Success a 10 | 11 | instance Functor (Validation e) where 12 | fmap f (Failure e) = Failure e 13 | fmap f (Success x) = Success (f x) 14 | 15 | instance Monoid e => Applicative (Validation e) where 16 | pure = Success 17 | 18 | Failure e1 <*> b = Failure $ e1 `mappend` case b of 19 | Failure e2 -> e2 20 | Success _ -> mempty 21 | Success _ <*> Failure e = Failure e 22 | Success f <*> Success x = Success (f x) 23 | 24 | instance Except (Validation e) e where 25 | throw = Failure 26 | -------------------------------------------------------------------------------- /a-law-breaking-hack/a-law-breaking-hack.cabal: -------------------------------------------------------------------------------- 1 | name: a-law-breaking-hack 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/githubuser/a-law-breaking-hack#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Author name here 9 | maintainer: example@example.com 10 | copyright: 2020 Author name here 11 | category: Web 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | extra-source-files: README.md 15 | 16 | executable a-law-breaking-hack 17 | hs-source-dirs: src 18 | main-is: Main.hs 19 | default-language: Haskell2010 20 | build-depends: base >= 4.7 && < 5 21 | -------------------------------------------------------------------------------- /things-you-should-avoid/things-you-should-avoid.cabal: -------------------------------------------------------------------------------- 1 | name: things-you-should-avoid 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/githubuser/things-you-should-avoid#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Author name here 9 | maintainer: example@example.com 10 | copyright: 2020 Author name here 11 | category: Web 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | extra-source-files: README.md 15 | 16 | executable things-you-should-avoid 17 | hs-source-dirs: src 18 | main-is: Main.hs 19 | default-language: Haskell2010 20 | build-depends: base >= 4.7 && < 5 21 | -------------------------------------------------------------------------------- /poly-type-of-saga/part1-try-unify/part1-try-unify.cabal: -------------------------------------------------------------------------------- 1 | name: part1-try-unify 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/githubuser/part1-try-unify#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Author name here 9 | maintainer: example@example.com 10 | copyright: 2020 Author name here 11 | category: Web 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | extra-source-files: README.md 15 | 16 | executable part1-try-unify 17 | hs-source-dirs: src 18 | main-is: Main.hs 19 | default-language: Haskell2010 20 | build-depends: base >= 4.7 && < 5, 21 | QuickCheck 22 | -------------------------------------------------------------------------------- /trouble-in-paradise-fibonacci/stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: nothunks-0.1.2@sha256:ec366664bb611ba8ce3a48aee626804039ea53517de7788b8705c76be0dcfa72,2235 9 | pantry-tree: 10 | size: 342 11 | sha256: 14422b7789f33fd838bfec9c1c7af152dc211c9633db22d310ac579e84e4afb3 12 | original: 13 | hackage: nothunks-0.1.2 14 | snapshots: 15 | - completed: 16 | size: 533252 17 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/27.yaml 18 | sha256: c2aaae52beeacf6a5727c1010f50e89d03869abfab6d2c2658ade9da8ed50c73 19 | original: lts-16.27 20 | -------------------------------------------------------------------------------- /custom-type-equality-errors/custom-type-equality-errors.cabal: -------------------------------------------------------------------------------- 1 | name: custom-type-equality-errors 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/githubuser/custom-type-equality-errors#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Author name here 9 | maintainer: example@example.com 10 | copyright: 2021 Author name here 11 | category: Web 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | extra-source-files: README.md 15 | 16 | executable custom-type-equality-errors 17 | hs-source-dirs: src 18 | main-is: Main.hs 19 | default-language: Haskell2010 20 | build-depends: base >= 4.7 && < 5, 21 | type-level-sets 22 | -------------------------------------------------------------------------------- /poly-type-of-saga/part2-enumerate-type-vars/part2-enumerate-type-vars.cabal: -------------------------------------------------------------------------------- 1 | name: part2-enumerate-type-vars 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/githubuser/part2-enumerate-type-vars#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Author name here 9 | maintainer: example@example.com 10 | copyright: 2020 Author name here 11 | category: Web 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | extra-source-files: README.md 15 | 16 | executable part2-enumerate-type-vars 17 | hs-source-dirs: src 18 | main-is: Main.hs 19 | other-modules: TypeToString 20 | default-language: Haskell2010 21 | build-depends: base >= 4.7 && < 5 22 | -------------------------------------------------------------------------------- /custom-type-equality-errors/stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: type-level-sets-0.8.9.0@sha256:e29f4045b68e46e0f88153c63f48fb026917eeacafd9b81fc059417a85e68031,3123 9 | pantry-tree: 10 | size: 382 11 | sha256: e7b4e38017e1231b70c511f95a057692a43366408137639da510b25155662a09 12 | original: 13 | hackage: type-level-sets-0.8.9.0 14 | snapshots: 15 | - completed: 16 | size: 563099 17 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/2.yaml 18 | sha256: 92b1a17e31d0a978fca4bf270305d4d1dd8092271bf60eafbc9349c890854026 19 | original: lts-17.2 20 | -------------------------------------------------------------------------------- /exhaustive-unordered-pattern-matching/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | {-# LANGUAGE NamedFieldPuns #-} 4 | {-# LANGUAGE PatternSynonyms #-} 5 | {-# LANGUAGE ViewPatterns #-} 6 | 7 | module Main (module Main) where 8 | 9 | data R = R 10 | { a :: Int 11 | , b :: Int 12 | } 13 | 14 | serializeA :: Int -> IO () 15 | serializeA = mempty 16 | 17 | serializeB :: Int -> IO () 18 | serializeB = mempty 19 | 20 | dup :: a -> (a, a) 21 | dup x = (x, x) 22 | 23 | -- infixr 0 :& 24 | -- pattern (:&) :: a -> a -> a 25 | -- pattern p1 :& p2 <- (dup -> (p1, p2)) 26 | -- {-# COMPLETE (:&) #-} 27 | 28 | pattern (:&) :: a -> a -> a 29 | pattern a0:&a1 <- a0@a1 30 | {-# COMPLETE (:&) #-} 31 | 32 | serializeR :: R -> IO () 33 | serializeR (R _ _ :& R {b, a}) = do 34 | serializeA a 35 | serializeB b 36 | 37 | main :: IO () 38 | main = pure () 39 | -------------------------------------------------------------------------------- /hierarchical-free-monads-mostly-pointless/src/FT.hs: -------------------------------------------------------------------------------- 1 | module FT where 2 | 3 | import System.Random 4 | 5 | data LogLevel = Info 6 | type Message = String 7 | 8 | class Monad m => MonadLogger m where 9 | logMessage :: LogLevel -> Message -> m () 10 | 11 | class MonadLogger m => MonadApp m where 12 | getRandomInt :: (Int, Int) -> m Int 13 | 14 | instance MonadLogger IO where 15 | logMessage _ = putStrLn 16 | 17 | instance MonadApp IO where 18 | getRandomInt = randomRIO 19 | 20 | runMonadApp :: IO a -> IO a 21 | runMonadApp = id 22 | 23 | -- Corresponds to the original @logInfo :: Message -> App ()@ 24 | logInfo :: MonadApp m => Message -> m () 25 | logInfo = logMessage Info 26 | 27 | printRandomFactorial :: MonadApp m => m () 28 | printRandomFactorial = do 29 | n <- getRandomInt (1, 100) 30 | logInfo $ show $ product [1..n] 31 | -------------------------------------------------------------------------------- /custom-warning-hack/custom-warning-hack.cabal: -------------------------------------------------------------------------------- 1 | name: custom-warning-hack 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/githubuser/custom-warning-hack#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Author name here 9 | maintainer: example@example.com 10 | copyright: 2021 Author name here 11 | category: Web 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | extra-source-files: README.md 15 | 16 | executable custom-warning-hack 17 | hs-source-dirs: src 18 | main-is: Main.hs 19 | default-language: Haskell2010 20 | build-depends: base >= 4.7 && < 5, 21 | transformers, 22 | mtl, 23 | mmorph 24 | ghc-options: -Wall 25 | -------------------------------------------------------------------------------- /validation-leak/validation-leak.cabal: -------------------------------------------------------------------------------- 1 | name: validation-leak 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/githubuser/validation-leak#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Author name here 9 | maintainer: example@example.com 10 | copyright: 2017 Author name here 11 | category: Web 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | extra-source-files: README.md 15 | 16 | executable validation-leak 17 | hs-source-dirs: src 18 | main-is: Main.hs 19 | default-language: Haskell2010 20 | build-depends: base >= 4.7 && < 5 21 | other-modules: Except, 22 | Fine, 23 | Leak 24 | ghc-options: -O2 -rtsopts "-with-rtsopts=-sstderr" 25 | -------------------------------------------------------------------------------- /trouble-in-paradise-fibonacci/trouble-in-paradise-fibonacci.cabal: -------------------------------------------------------------------------------- 1 | name: trouble-in-paradise-fibonacci 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/githubuser/trouble-in-paradise-fibonacci#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Author name here 9 | maintainer: example@example.com 10 | copyright: 2021 Author name here 11 | category: Web 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | extra-source-files: README.md 15 | 16 | executable trouble-in-paradise-fibonacci 17 | hs-source-dirs: src 18 | main-is: Main.hs 19 | default-language: Haskell2010 20 | build-depends: base >= 4.7 && < 5, 21 | nothunks 22 | ghc-options: -O2 -rtsopts "-with-rtsopts=-sstderr" 23 | -------------------------------------------------------------------------------- /mineunifier/src/Mineunifier/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | 7 | module Mineunifier.Util where 8 | 9 | import GHC.TypeLits 10 | 11 | type family HeadDef z xs where 12 | HeadDef z '[] = z 13 | HeadDef _ (x ': _) = x 14 | 15 | type family Take n xs where 16 | Take 0 _ = '[] 17 | Take _ '[] = '[] 18 | Take n (x ': xs) = x ': Take (n - 1) xs 19 | 20 | type family Drop n xs where 21 | Drop 0 xs = xs 22 | Drop _ '[] = '[] 23 | Drop n (x ': xs) = Drop (n - 1) xs 24 | 25 | infixr 5 ++ 26 | type family xs ++ ys where 27 | '[] ++ ys = ys 28 | (x ': xs) ++ ys = x ': xs ++ ys 29 | 30 | type family Concat xss where 31 | Concat '[] = '[] 32 | Concat (xs ': xss) = xs ++ Concat xss 33 | -------------------------------------------------------------------------------- /better-syntax-for-eDSLs/src/Unscoped.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE MagicHash #-} 5 | {-# LANGUAGE OverloadedRecordDot #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE StandaloneKindSignatures #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | 12 | module Unscoped where 13 | 14 | import Common 15 | 16 | import GHC.TypeLits 17 | import GHC.Records 18 | import GHC.Exts 19 | 20 | instance (res ~ (Term -> Term), KnownSymbol name) => HasField name (Prefix "lam") res where 21 | getField _ = Lam $ symbolVal' (proxy# @name) 22 | 23 | instance (res ~ Term, KnownSymbol name) => HasField name (Prefix "var") res where 24 | getField _ = Var $ symbolVal' (proxy# @name) 25 | 26 | -- >>> print owl 27 | -- Lam "f" (Lam "g" (App (Var "g") (App (Var "f") (Var "g")))) 28 | owl :: Term 29 | owl = lam.f $ lam.g $ app var.g (app var.f var.g) 30 | -------------------------------------------------------------------------------- /poly-type-of-saga/part2-enumerate-type-vars/src/TypeToString.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | 4 | module TypeToString where 5 | 6 | import Data.Proxy 7 | 8 | class TypeToString a where 9 | typeToString :: Proxy a -> String 10 | 11 | instance TypeToString Bool where 12 | typeToString _ = "Bool" 13 | 14 | instance TypeToString Int where 15 | typeToString _ = "Int" 16 | 17 | instance (TypeToString a, TypeToString b) => TypeToString (a, b) where 18 | typeToString _ = concat ["(", typeToString (Proxy @a), ", ", typeToString (Proxy @b), ")"] 19 | 20 | instance TypeToString a => TypeToString [a] where 21 | typeToString _ = concat ["[", typeToString (Proxy @a), "]"] 22 | 23 | -- >>> :set -XTypeApplications 24 | -- >>> import Data.Proxy 25 | -- >>> typeToString $ Proxy @[(Int, Bool)] 26 | -- "[(Int, Bool)]" 27 | -- >>> import Data.Typeable 28 | -- >>> typeRep $ Proxy @[(Int, Bool)] 29 | -- [(Int,Bool)] 30 | -------------------------------------------------------------------------------- /lazy-reverse/.stack/config.yaml: -------------------------------------------------------------------------------- 1 | # This file contains default non-project-specific settings for Stack, used 2 | # in all projects. For more information about Stack's configuration, see 3 | # http://docs.haskellstack.org/en/stable/configure/yaml/ 4 | 5 | # The following parameters are used by 'stack new' to automatically fill fields 6 | # in the Cabal file. We recommend uncommenting them and filling them out if 7 | # you intend to use 'stack new'. 8 | # See https://docs.haskellstack.org/en/stable/configure/yaml/non-project/#templates 9 | templates: 10 | params: 11 | # author-name: 12 | # author-email: 13 | # copyright: 14 | # github-username: 15 | 16 | # The following parameter specifies Stack's output styles; STYLES is a 17 | # colon-delimited sequence of key=value, where 'key' is a style name and 18 | # 'value' is a semicolon-delimited list of 'ANSI' SGR (Select Graphic 19 | # Rendition) control codes (in decimal). Use 'stack ls stack-colors --basic' 20 | # to see the current sequence. 21 | # stack-colors: STYLES 22 | -------------------------------------------------------------------------------- /mineunifier/mineunifier.cabal: -------------------------------------------------------------------------------- 1 | name: mineunifier 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/githubuser/mineunifier#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Author name here 9 | maintainer: example@example.com 10 | copyright: 2022 Author name here 11 | category: Web 12 | build-type: Simple 13 | extra-source-files: README.md 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: Mineunifier.Core, 19 | Mineunifier.Game, 20 | Mineunifier.IO, 21 | Mineunifier.Test, 22 | Mineunifier.Util 23 | build-depends: base >= 4.7 && < 5 24 | default-language: Haskell2010 25 | ghc-options: -Wall 26 | 27 | source-repository head 28 | type: git 29 | location: https://github.com/githubuser/mineunifier 30 | -------------------------------------------------------------------------------- /generalizing-unliftio/generalizing-unliftio.cabal: -------------------------------------------------------------------------------- 1 | name: generalizing-unliftio 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/githubuser/generalizing-unliftio#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Author name here 9 | maintainer: example@example.com 10 | copyright: 2021 Author name here 11 | category: Web 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | extra-source-files: README.md 15 | 16 | executable generalizing-unliftio 17 | hs-source-dirs: src 18 | main-is: Main.hs 19 | other-modules: SomeAction, 20 | Peel, 21 | Unlift, 22 | UnliftIO, 23 | UnliftPeel 24 | default-language: Haskell2010 25 | build-depends: base >= 4.7 && < 5, 26 | transformers, 27 | mtl, 28 | mmorph 29 | ghc-options: -Wall 30 | -------------------------------------------------------------------------------- /custom-warning-hack/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | 6 | module Main where 7 | 8 | import Control.Applicative 9 | import Data.Proxy 10 | 11 | data D 12 | = C0 13 | | C1 Int Bool 14 | | C2 Word 15 | | C3 Char 16 | 17 | parseC0 :: Parse D 18 | parseC1 :: Parse D 19 | parseC3 :: Parse D 20 | 21 | parseD :: Parse D 22 | parseD = parseC0 <|> parseC1 <|> parseC3 23 | 24 | class Warning warning where 25 | warning :: warning -> () 26 | 27 | data FIX_ME_BUT_FIRST request a 28 | = LOOK_RIGHT_ABOVE 29 | | FIX_ME_BUT_FIRST request a 30 | 31 | data IMPLEMENT_PARSING_FOR = IMPLEMENT_PARSING_FOR 32 | 33 | instance Warning (FIX_ME_BUT_FIRST IMPLEMENT_PARSING_FOR D) where 34 | warning LOOK_RIGHT_ABOVE = () 35 | warning (FIX_ME_BUT_FIRST IMPLEMENT_PARSING_FOR C0{}) = () 36 | warning (FIX_ME_BUT_FIRST IMPLEMENT_PARSING_FOR C1{}) = () 37 | warning (FIX_ME_BUT_FIRST IMPLEMENT_PARSING_FOR C3{}) = () 38 | 39 | type Parse = Proxy 40 | parseC0 = Proxy 41 | parseC1 = Proxy 42 | parseC3 = Proxy 43 | 44 | main :: IO () 45 | main = mempty 46 | -------------------------------------------------------------------------------- /better-syntax-for-eDSLs/better-syntax-for-eDSLs.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | 3 | name: better-syntax-for-eDSLs 4 | version: 0.1.0.0 5 | -- synopsis: 6 | -- description: 7 | license: BSD-3-Clause 8 | license-file: LICENSE 9 | author: Author name here 10 | maintainer: example@example.com 11 | copyright: 2024 Author name here 12 | category: Web 13 | build-type: Simple 14 | extra-source-files: README.md 15 | CHANGELOG.md 16 | 17 | executable better-syntax-for-eDSLs 18 | hs-source-dirs: src 19 | main-is: Main.hs 20 | other-modules: Common 21 | Unscoped 22 | Scoped 23 | default-language: Haskell2010 24 | build-depends: base >= 4.7 && < 5 25 | ghc-options: -Wall 26 | -Wcompat 27 | -Widentities 28 | -Wincomplete-record-updates 29 | -Wincomplete-uni-patterns 30 | -Wmissing-home-modules 31 | -Wpartial-fields 32 | -Wredundant-constraints 33 | -------------------------------------------------------------------------------- /exhaustive-unordered-pattern-matching/exhaustive-unordered-pattern-matching.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | 3 | name: exhaustive-unordered-pattern-matching 4 | version: 0.1.0.0 5 | -- synopsis: 6 | -- description: 7 | homepage: https://github.com/githubuser/exhaustive-unordered-pattern-matching#readme 8 | license: BSD-3-Clause 9 | license-file: LICENSE 10 | author: Author name here 11 | maintainer: example@example.com 12 | copyright: 2024 Author name here 13 | category: Web 14 | build-type: Simple 15 | extra-source-files: README.md 16 | CHANGELOG.md 17 | 18 | executable exhaustive-unordered-pattern-matching 19 | hs-source-dirs: src 20 | main-is: Main.hs 21 | default-language: Haskell2010 22 | build-depends: base >= 4.7 && < 5 23 | ghc-options: -Wall 24 | -Wcompat 25 | -Widentities 26 | -Wincomplete-record-updates 27 | -Wincomplete-uni-patterns 28 | -Wmissing-export-lists 29 | -Wmissing-home-modules 30 | -Wpartial-fields 31 | -Wredundant-constraints 32 | -------------------------------------------------------------------------------- /better-counterexample-minimization/better-counterexample-minimization.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | 3 | name: better-counterexample-minimization 4 | version: 0.1.0.0 5 | -- synopsis: 6 | -- description: 7 | homepage: https://github.com/githubuser/better-counterexample-minimization#readme 8 | license: BSD-3-Clause 9 | license-file: LICENSE 10 | author: Author name here 11 | maintainer: example@example.com 12 | copyright: 2025 Author name here 13 | category: Web 14 | build-type: Simple 15 | extra-source-files: README.md 16 | CHANGELOG.md 17 | 18 | executable better-counterexample-minimization 19 | hs-source-dirs: src 20 | main-is: Main.hs 21 | default-language: Haskell2010 22 | build-depends: base >= 4.7 && < 5, 23 | QuickCheck 24 | ghc-options: -Wall 25 | -Wcompat 26 | -Widentities 27 | -Wincomplete-record-updates 28 | -Wincomplete-uni-patterns 29 | -Wmissing-export-lists 30 | -Wmissing-home-modules 31 | -Wpartial-fields 32 | -Wredundant-constraints 33 | -------------------------------------------------------------------------------- /lazy-reverse/lazy-reverse.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | 3 | name: lazy-reverse 4 | version: 0.1.0.0 5 | -- synopsis: 6 | -- description: 7 | homepage: https://github.com/githubuser/lazy-reverse#readme 8 | license: BSD-3-Clause 9 | license-file: LICENSE 10 | author: Author name here 11 | maintainer: example@example.com 12 | copyright: 2025 Author name here 13 | category: Web 14 | build-type: Simple 15 | extra-source-files: README.md 16 | CHANGELOG.md 17 | 18 | executable lazy-reverse 19 | hs-source-dirs: src 20 | main-is: Main.hs 21 | default-language: Haskell2010 22 | build-depends: base >= 4.7 && < 5 23 | ghc-options: -Wall 24 | -Wcompat 25 | -Widentities 26 | -Wincomplete-record-updates 27 | -Wincomplete-uni-patterns 28 | -Wmissing-export-lists 29 | -Wmissing-home-modules 30 | -Wpartial-fields 31 | -Wredundant-constraints 32 | -rtsopts 33 | "-with-rtsopts=-s" 34 | 35 | source-repository head 36 | type: git 37 | location: https://github.com/githubuser/lazy-reverse 38 | -------------------------------------------------------------------------------- /poly-traversable/src/FunDep.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, DefaultSignatures, FunctionalDependencies, TypeFamilies #-} 2 | {-# LANGUAGE ScopedTypeVariables, TypeApplications #-} 3 | module FunDep where 4 | 5 | import Data.Word 6 | import Data.Foldable 7 | import Data.Functor.Const 8 | import Data.ByteString (ByteString) 9 | import qualified Data.ByteString as BS 10 | import Data.Text (Text) 11 | import qualified Data.Text as Text 12 | 13 | class PolyFunctor s t a b | s -> a, t -> b, s b -> t, t a -> s where 14 | pmap :: (a -> b) -> s -> t 15 | default pmap :: (Functor f, s ~ f a, t ~ f b) => (a -> b) -> s -> t 16 | pmap = fmap 17 | 18 | class PolyFoldable s a | s -> a where 19 | ptoList :: s -> [a] 20 | default ptoList :: (Foldable f, s ~ f a) => s -> [a] 21 | ptoList = toList 22 | 23 | class (PolyFunctor s t a b, PolyFoldable s a) => PolyTraversable s t a b | s -> a, t -> b, s b -> t, t a -> s where 24 | ptraverse :: Applicative g => (a -> g b) -> s -> g t 25 | default ptraverse :: (Traversable f, Applicative g, s ~ f a, t ~ f b) => (a -> g b) -> s -> g t 26 | ptraverse = traverse 27 | 28 | pfoldMapDefault :: forall s a m. (PolyTraversable s s a a, Monoid m) => (a -> m) -> s -> m 29 | pfoldMapDefault f = getConst . ptraverse @s @s (Const . f) 30 | 31 | instance PolyFunctor ByteString Text Word8 Char where 32 | pmap f = Text.pack . map f . BS.unpack 33 | -------------------------------------------------------------------------------- /lazy-reverse/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2025 Author name here 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are met: 5 | 6 | 1. Redistributions of source code must retain the above copyright notice, this 7 | list of conditions and the following disclaimer. 8 | 9 | 2. Redistributions in binary form must reproduce the above copyright notice, 10 | this list of conditions and the following disclaimer in the documentation 11 | and/or other materials provided with the distribution. 12 | 13 | 3. Neither the name of the copyright holder nor the names of its contributors 14 | may be used to endorse or promote products derived from this software 15 | without specific prior written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 18 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 19 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 21 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 22 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 23 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 24 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 26 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /better-syntax-for-eDSLs/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2024 Author name here 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are met: 5 | 6 | 1. Redistributions of source code must retain the above copyright notice, this 7 | list of conditions and the following disclaimer. 8 | 9 | 2. Redistributions in binary form must reproduce the above copyright notice, 10 | this list of conditions and the following disclaimer in the documentation 11 | and/or other materials provided with the distribution. 12 | 13 | 3. Neither the name of the copyright holder nor the names of its contributors 14 | may be used to endorse or promote products derived from this software 15 | without specific prior written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 18 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 19 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 21 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 22 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 23 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 24 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 26 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /better-counterexample-minimization/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2025 Author name here 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are met: 5 | 6 | 1. Redistributions of source code must retain the above copyright notice, this 7 | list of conditions and the following disclaimer. 8 | 9 | 2. Redistributions in binary form must reproduce the above copyright notice, 10 | this list of conditions and the following disclaimer in the documentation 11 | and/or other materials provided with the distribution. 12 | 13 | 3. Neither the name of the copyright holder nor the names of its contributors 14 | may be used to endorse or promote products derived from this software 15 | without specific prior written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 18 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 19 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 21 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 22 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 23 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 24 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 26 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /exhaustive-unordered-pattern-matching/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2024 Author name here 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are met: 5 | 6 | 1. Redistributions of source code must retain the above copyright notice, this 7 | list of conditions and the following disclaimer. 8 | 9 | 2. Redistributions in binary form must reproduce the above copyright notice, 10 | this list of conditions and the following disclaimer in the documentation 11 | and/or other materials provided with the distribution. 12 | 13 | 3. Neither the name of the copyright holder nor the names of its contributors 14 | may be used to endorse or promote products derived from this software 15 | without specific prior written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 18 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 19 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 21 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 22 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 23 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 24 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 26 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /avoid-overlapping-recursive/src/TF.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MagicHash #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | 12 | module TF where 13 | 14 | import GHC.Exts (Proxy#, proxy#) 15 | 16 | data N = Z | S N 17 | 18 | type family Domain ab where 19 | Domain (a -> _) = a 20 | 21 | type family Codomain ab where 22 | Codomain (_ -> b) = b 23 | 24 | type family AppFunc f n a where 25 | AppFunc f 'Z a = f a 26 | AppFunc f ('S n) a = f (Domain a) -> AppFunc f n (Codomain a) 27 | 28 | class Applyable a n where 29 | apply :: Applicative f => Proxy# n -> f a -> AppFunc f n a 30 | 31 | instance Applyable a 'Z where 32 | apply _ = id 33 | 34 | instance (ab ~ (a -> b), Applyable b n) => Applyable ab ('S n) where 35 | apply _ f = \a -> apply (proxy# :: Proxy# n) $ f <*> a 36 | 37 | liftAn 38 | :: forall n f a b. (Applyable b n, Applicative f) 39 | => (a -> b) -> f a -> AppFunc f n b 40 | liftAn f = apply (proxy# :: Proxy# n) . fmap f 41 | 42 | 43 | 44 | test1 :: (Enum a, Num a) => [a] 45 | test1 = liftAn @'Z succ [1..5] 46 | 47 | test2 :: (Enum a, Num a) => [a] 48 | test2 = liftAn @('S 'Z) (+) [1..5] [3..5] 49 | 50 | test3 :: (Enum a, Num a) => [a] 51 | test3 = liftAn @('S ('S 'Z)) (\x y z -> x + y * z) [1..5] [3..5] [5] 52 | -------------------------------------------------------------------------------- /mineunifier/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2022 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /validation-leak/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /a-law-breaking-hack/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2020 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /custom-warning-hack/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2021 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /generalizing-unliftio/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2021 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /things-you-should-avoid/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2020 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /custom-type-equality-errors/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2021 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /trouble-in-paradise-fibonacci/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2021 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /poly-type-of-saga/part1-try-unify/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2020 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /poly-type-of-saga/part2-enumerate-type-vars/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2020 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /avoid-overlapping-recursive/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MagicHash #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | 9 | module Main where 10 | 11 | import GHC.Exts (Proxy#, proxy#) 12 | 13 | type family IsFun a :: Bool where 14 | IsFun (_ -> _) = 'True 15 | IsFun _ = 'False 16 | 17 | class DispatchApN f a b (ts :: Bool) where 18 | dispatchApN :: Proxy# ts -> f a -> b 19 | 20 | instance f a ~ b => DispatchApN f a b 'False where 21 | dispatchApN _ = id 22 | 23 | instance (Applicative f, xa ~ (x -> a), fxb ~ (f x -> b), ApN f a b) => 24 | DispatchApN f xa fxb 'True where 25 | dispatchApN _ f = \a -> apN $ f <*> a 26 | 27 | class Applicative f => ApN f a b where 28 | apN :: f a -> b 29 | 30 | instance (Applicative f, DispatchApN f a b (IsFun b)) => ApN f a b where 31 | apN = dispatchApN (proxy# :: Proxy# (IsFun b)) 32 | 33 | liftAn :: ApN f a b => (x -> a) -> f x -> b 34 | liftAn f = apN . fmap f 35 | 36 | test1 :: (Enum a, Num a) => [a] 37 | test1 = liftAn succ [1..5] 38 | 39 | test2 :: (Enum a, Num a) => [a] 40 | test2 = liftAn (+) [1..5] [3..5] 41 | 42 | test3 :: (Enum a, Num a) => [a] 43 | test3 = liftAn (\x y z -> x + y * z) [1..5] [3..5] [5] 44 | 45 | test4 :: (Enum a, Num a) => Maybe (Maybe a) 46 | test4 = (liftAn . liftAn) (+) (Just (Just 4)) (Just (Just 1)) 47 | 48 | test5 :: IO Int 49 | test5 = do 50 | n <- liftAn (*) readLn readLn 51 | return $ n + 1 52 | 53 | main :: IO () 54 | main = mempty 55 | -------------------------------------------------------------------------------- /generalizing-unliftio/src/UnliftIO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | 6 | module UnliftIO where 7 | 8 | import SomeAction 9 | 10 | import Control.Concurrent 11 | import Control.Monad.Except 12 | import Control.Monad.Morph 13 | import Control.Monad.Trans.Reader 14 | 15 | class MonadIO m => MonadUnliftIO m where 16 | withRunInIO :: ((forall a. m a -> IO a) -> IO r) -> m r 17 | 18 | instance MonadUnliftIO IO where 19 | withRunInIO k = k id 20 | 21 | instance MonadUnliftIO m => MonadUnliftIO (ReaderT e m) where 22 | withRunInIO k = ReaderT $ \r -> withRunInIO $ \runInIO -> k $ runInIO . flip runReaderT r 23 | 24 | liftU :: MonadUnliftIO m => IO r -> m r 25 | liftU a = withRunInIO $ \_ -> a 26 | 27 | forkU :: MonadUnliftIO m => m () -> m ThreadId 28 | forkU a = withRunInIO $ \runInIO -> forkIO $ runInIO a 29 | 30 | newtype App a = App 31 | { unApp :: ReaderT () IO a 32 | } deriving newtype (Functor, Applicative, Monad, MonadIO, MonadUnliftIO) 33 | deriving anyclass (SomeAction) 34 | 35 | testApp :: ExceptT () App () 36 | testApp = throwError () `catchError` \() -> do 37 | _ <- lift $ forkU someAction 38 | printM () 39 | 40 | newtype AppT m a = AppT 41 | { unAppT :: ReaderT () m a 42 | } deriving newtype (Functor, Applicative, Monad, MonadIO, MonadUnliftIO, MonadError e, MFunctor) 43 | deriving anyclass (SomeAction) 44 | 45 | testAppT :: AppT (ExceptT () IO) () 46 | testAppT = throwError () `catchError` \() -> do 47 | _ <- hoist lift $ forkU someAction 48 | printM () 49 | -------------------------------------------------------------------------------- /lazy-reverse/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -O2 #-} 2 | {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} 3 | {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} 4 | 5 | module Main (main) where 6 | 7 | import qualified Data.List as List 8 | import System.Environment (getArgs) 9 | 10 | nats :: [Int] 11 | nats = [1..] 12 | 13 | fibs :: [Int] 14 | fibs = 0 : scanl (+) 1 fibs 15 | 16 | fibs' :: [Int] 17 | fibs' = 0 : List.scanl' (+) 1 fibs' 18 | 19 | rev_knot :: [a] -> [a] 20 | rev_knot xs0 = let (xs3, xs5) = go [] xs3 xs0 in xs5 where 21 | go xs2 ~[] [] = (xs2, []) 22 | go xs2 ~(x4:xs4) (x1:xs1) = 23 | let (xs3, xs5) = go (x1:xs2) xs4 xs1 24 | in (xs3, x4:xs5) 25 | {-# INLINE rev_knot #-} 26 | 27 | rev_forw :: [a] -> [a] 28 | rev_forw xs0 = foldr (\_ k ~(x:xs) -> x : k xs) (\_ -> []) xs0 (reverse xs0) 29 | {-# INLINE rev_forw #-} 30 | 31 | rev_back :: [a] -> [a] 32 | rev_back xs0 = snd $ foldr (\_ ~(~(x:xs1), xs2) -> (xs1, x:xs2)) (xs0, []) xs0 33 | {-# INLINE rev_back #-} 34 | 35 | main :: IO () 36 | main = do 37 | [producerName, limitName, consumerName, listName] <- getArgs 38 | let n = 1000000 39 | (pre, post) = case limitName of 40 | "before" -> (take n, id) 41 | "after" -> (id, take n) 42 | consumer = case consumerName of 43 | "sum" -> sum 44 | "length" -> length 45 | producer = case producerName of 46 | "reverse" -> reverse 47 | "rev_knot" -> rev_knot 48 | "rev_forw" -> rev_forw 49 | "rev_back" -> rev_back 50 | list = case listName of 51 | "nats" -> nats 52 | "fibs" -> fibs 53 | "fibs'" -> fibs' 54 | print . consumer . post . producer $ pre list 55 | -------------------------------------------------------------------------------- /a-law-breaking-hack/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Exception 4 | import Data.IORef 5 | import System.IO.Unsafe 6 | 7 | lastIsFalse :: [Bool] 8 | lastIsFalse = unsafePerformIO $ do 9 | next <- newIORef False 10 | let go = do 11 | b <- unsafeInterleaveIO $ readIORef next 12 | bs <- unsafeInterleaveIO $ do 13 | writeIORef next True 14 | _ <- evaluate b 15 | writeIORef next False 16 | go 17 | pure $ b : bs 18 | go 19 | 20 | foldr' :: (a -> r -> r) -> r -> [a] -> r 21 | foldr' f = foldr (($!) . f) 22 | 23 | -- >>> init . take 1 $ zip [1..] lastIsFalse 24 | -- [] 25 | -- >>> last . take 1 $ zip [1..] lastIsFalse 26 | -- (1,False) 27 | 28 | -- >>> init . take 2 $ zip [1..] lastIsFalse 29 | -- [(1,True)] 30 | -- >>> last . take 2 $ zip [1..] lastIsFalse 31 | -- (2,False) 32 | 33 | -- >>> init . take 5 $ zip [1..] lastIsFalse 34 | -- [(1,True),(2,True),(3,True),(4,True)] 35 | -- >>> last . take 5 $ zip [1..] lastIsFalse 36 | -- (5,False) 37 | 38 | -- >>> take 5 $ zip [1..] lastIsFalse 39 | -- [(1,False),(2,False),(3,False),(4,False),(5,False)] 40 | 41 | -- >>> foldr' (:) [] . take 5 $ zip [1..] lastIsFalse 42 | -- [(1,True),(2,True),(3,True),(4,True),(5,False)] 43 | 44 | -- >>> traverse pure . take 5 $ zip [1..] lastIsFalse 45 | -- [(1,True),(2,True),(3,True),(4,True),(5,False)] 46 | 47 | -- >>> pure . take 5 $ zip [1..] lastIsFalse 48 | -- [(1,False),(2,False),(3,False),(4,False),(5,False)] 49 | 50 | -- >>> traverse pure . take 3 $ zip [1..] lastIsFalse 51 | -- [(1,True),(2,True),(3,False)] 52 | -- >>> traverse pure . take 5 $ zip [1..] lastIsFalse 53 | -- [(1,True),(2,True),(3,False),(4,True),(5,False)] 54 | 55 | main :: IO () 56 | main = mempty 57 | -------------------------------------------------------------------------------- /avoid-overlapping-recursive/src/BackwardsTF.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MagicHash #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | 12 | module BackwardsTF where 13 | 14 | import GHC.Exts (Proxy#, proxy#) 15 | 16 | data N = Z | S N 17 | 18 | type family UnAppFunc n a where 19 | UnAppFunc 'Z (f b) = b 20 | UnAppFunc ('S n) (f a -> b) = a -> UnAppFunc n b 21 | 22 | type family CountArgs f where 23 | CountArgs (_ -> b) = 'S (CountArgs b) 24 | CountArgs _ = 'Z 25 | 26 | class Applyable (f :: * -> *) b n where 27 | apply :: Proxy# n -> f (UnAppFunc n b) -> b 28 | 29 | instance b ~ f a => Applyable f b 'Z where 30 | apply _ = id 31 | 32 | instance (ab ~ (f a -> b), Applyable f b n, Applicative f) => Applyable f ab ('S n) where 33 | apply _ f = \a -> apply (proxy# :: Proxy# n) $ f <*> a 34 | 35 | liftAn 36 | :: forall n f a b. (n ~ CountArgs b, Applyable f b n, Applicative f) 37 | => (a -> UnAppFunc n b) -> f a -> b 38 | liftAn f = apply (proxy# :: Proxy# n) . fmap f 39 | 40 | 41 | 42 | test1 :: (Enum a, Num a) => [a] 43 | test1 = liftAn succ [1..5] 44 | 45 | test2 :: (Enum a, Num a) => [a] 46 | test2 = liftAn (+) [1..5] [3..5] 47 | 48 | test3 :: (Enum a, Num a) => [a] 49 | test3 = liftAn (\x y z -> x + y * z) [1..5] [3..5] [5] 50 | 51 | test4 :: (Enum a, Num a) => Maybe (Maybe a) 52 | test4 = (liftAn . liftAn) (+) (Just (Just 0)) Nothing 53 | 54 | test5 :: IO Int 55 | test5 = do 56 | n <- liftAn (*) readLn readLn 57 | return $ n + 1 58 | -------------------------------------------------------------------------------- /haskell-emacs-jump-to-definition/code.el: -------------------------------------------------------------------------------- 1 | ;; hasktags 2 | (add-to-list 'load-path "/hasktags-emacs") 3 | (load "hasktags") 4 | 5 | (defun my-xref-find-etags () 6 | (interactive) 7 | (let* ((xref-backend-functions '(etags--xref-backend)) 8 | (thing (xref-backend-identifier-at-point 'etags))) 9 | (xref-find-definitions thing))) 10 | (global-set-key (kbd "C-M-.") 'my-xref-find-etags) 11 | 12 | (defun jds-find-tags-file () 13 | "recursively searches each parent directory for a file named 'TAGS' and returns the 14 | path to that file or nil if a tags file is not found. Returns nil if the buffer is 15 | not visiting a file" 16 | (progn 17 | (defun find-tags-file-r (path) 18 | "find the tags file from the parent directories" 19 | (let* ((parent (file-name-directory path)) 20 | (possible-tags-file (concat parent "TAGS"))) 21 | (cond 22 | ((file-exists-p possible-tags-file) (throw 'found-it possible-tags-file)) 23 | ((string= "/TAGS" possible-tags-file) (error "no tags file found")) 24 | (t (find-tags-file-r (directory-file-name parent)))))) 25 | (if (buffer-file-name) 26 | (catch 'found-it 27 | (find-tags-file-r (buffer-file-name))) 28 | (error "buffer is not visiting a file")))) 29 | 30 | (defun jds-set-tags-file-path () 31 | "calls `jds-find-tags-file' to recursively search up the directory tree to find 32 | a file named 'TAGS'. If found, adds it to 'tags-table-list', otherwise raises an error." 33 | (interactive) 34 | (add-to-list 'tags-table-list (jds-find-tags-file))) 35 | 36 | (add-hook 'haskell-mode-hook 'jds-set-tags-file-path) 37 | 38 | (custom-set-variables 39 | <...> 40 | '(tags-case-fold-search nil) 41 | '(tags-table-list (quote ("/TAGS")))) 42 | -------------------------------------------------------------------------------- /things-you-should-avoid/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-methods #-} 2 | 3 | {-# LANGUAGE EmptyCase #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE Rank2Types #-} 7 | 8 | module Main where 9 | 10 | import Control.Monad 11 | import System.IO.Unsafe 12 | import Unsafe.Coerce 13 | 14 | class Avoid a where 15 | avoid :: a -> void 16 | 17 | data False 18 | instance Avoid False where 19 | avoid = \case{} 20 | 21 | data AnythingIsTrue = AnythingIsTrue (forall a. a) 22 | instance Avoid AnythingIsTrue where 23 | avoid (AnythingIsTrue void) = void 24 | 25 | newtype TypeLevelLoop = TypeLevelLoop TypeLevelLoop 26 | instance Avoid TypeLevelLoop where 27 | avoid (TypeLevelLoop loop) = avoid loop 28 | 29 | data TermLevelLoop = TermLevelLoop 30 | instance Avoid TermLevelLoop where 31 | avoid = avoid 32 | 33 | data Exception = Exception 34 | instance Avoid Exception where 35 | avoid Exception = error "You should have avoided this" 36 | 37 | data IncompleteImplementation = IncompleteImplementation 38 | instance Avoid IncompleteImplementation 39 | 40 | instance {-# OVERLAPPABLE #-} Avoid a where 41 | avoid = unsafeCoerce 42 | 43 | data UnsafePerformIO = UnsafePerformIO 44 | instance Avoid UnsafePerformIO where 45 | avoid UnsafePerformIO = 46 | unsafePerformIO . forever $ putStrLn "I will not use 'unsafePerformIO' anymore" 47 | 48 | newtype FalsePromise a = FalsePromise (Avoid a => a) 49 | instance Avoid (FalsePromise a) where 50 | avoid (FalsePromise x) = avoid x 51 | 52 | newtype Success cost = Success cost 53 | newtype AtAllCosts f = AtAllCosts 54 | { unAtAllCosts :: forall cost. f cost 55 | } 56 | instance Avoid (AtAllCosts Success) where 57 | avoid (AtAllCosts (Success void)) = void 58 | 59 | main :: IO () 60 | main = mempty 61 | -------------------------------------------------------------------------------- /avoid-overlapping-recursive/src/Bonus.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MagicHash #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | 9 | module Bonus where 10 | 11 | import GHC.Exts (Proxy#, proxy#) 12 | 13 | type family IsFun a :: Bool where 14 | IsFun (_ -> _) = 'True 15 | IsFun _ = 'False 16 | 17 | class DispatchApN f a b (ts :: Bool) where 18 | dispatchApN :: Proxy# ts -> f a -> b 19 | 20 | instance f a ~ b => DispatchApN f a b 'False where 21 | dispatchApN _ = id 22 | 23 | instance (Applicative f, xa ~ (x -> a), fxb ~ (f x -> b), ApN f a b) => 24 | DispatchApN f xa fxb 'True where 25 | dispatchApN _ f = \a -> apN $ f <*> a 26 | 27 | class Applicative f => ApN f a b where 28 | apN :: f a -> b 29 | 30 | type family And (a :: Bool) (b :: Bool) :: Bool where 31 | And 'True 'True = 'True 32 | And _ _ = 'False 33 | 34 | instance 35 | ( Applicative f 36 | , ifa ~ IsFun a, ifb ~ IsFun b, ifb ~ And ifa ifb 37 | , DispatchApN f a b ifb 38 | ) => ApN f a b where 39 | apN = dispatchApN (proxy# :: Proxy# ifb) 40 | 41 | liftAn :: ApN f a b => (x -> a) -> f x -> b 42 | liftAn f = apN . fmap f 43 | 44 | test1 :: (Enum a, Num a) => [a] 45 | test1 = liftAn succ [1..5] 46 | 47 | test2 :: (Enum a, Num a) => [a] 48 | test2 = liftAn (+) [1..5] [3..5] 49 | 50 | test3 :: (Enum a, Num a) => [a] 51 | test3 = liftAn (\x y z -> x + y * z) [1..5] [3..5] [5] 52 | 53 | test4 :: (Enum a, Num a) => Maybe (Maybe a) 54 | test4 = (liftAn . liftAn) (+) (Just (Just 0)) Nothing 55 | 56 | test5 :: IO Int 57 | test5 = do 58 | n <- liftAn (*) readLn readLn 59 | return $ n + 1 60 | 61 | test6 = liftAn (++) (Just "a") (Just "b") 62 | 63 | test7 = (liftAn . liftAn) (++) (Just (Just "a")) Nothing 64 | -------------------------------------------------------------------------------- /hierarchical-free-monads-mostly-pointless/src/HFT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE QuantifiedConstraints #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | 6 | module HFT where 7 | 8 | import FT 9 | 10 | import Control.Applicative 11 | import System.Random 12 | 13 | newtype Subsystem constr a = Subsystem 14 | { unSubsystem :: forall m. constr m => m a 15 | } 16 | 17 | instance (forall f. constr f => Functor f) => Functor (Subsystem constr) where 18 | fmap f (Subsystem a) = Subsystem $ fmap f a 19 | x <$ (Subsystem a) = Subsystem $ x <$ a 20 | 21 | instance (forall f. constr f => Applicative f) => Applicative (Subsystem constr) where 22 | pure x = Subsystem $ pure x 23 | Subsystem f <*> Subsystem a = Subsystem $ f <*> a 24 | Subsystem f <* Subsystem a = Subsystem $ f <* a 25 | Subsystem f *> Subsystem a = Subsystem $ f *> a 26 | liftA2 f (Subsystem a) (Subsystem b) = Subsystem $ liftA2 f a b 27 | 28 | instance (forall m. constr m => Monad m) => Monad (Subsystem constr) where 29 | return = pure 30 | Subsystem a >>= f = Subsystem $ a >>= unSubsystem . f 31 | a >> b = a *> b 32 | fail err = Subsystem $ fail err 33 | 34 | subsystem :: (forall m. constr2 m => constr1 m) => Subsystem constr1 a -> Subsystem constr2 a 35 | subsystem (Subsystem a) = Subsystem a 36 | 37 | instance (forall m. constr m => MonadLogger m) => MonadLogger (Subsystem constr) where 38 | logMessage level msg = Subsystem $ logMessage level msg 39 | 40 | instance (forall m. constr m => MonadApp m) => MonadApp (Subsystem constr) where 41 | getRandomInt range = Subsystem $ getRandomInt range 42 | 43 | type Logger = Subsystem MonadLogger 44 | type App = Subsystem MonadApp 45 | 46 | runApp :: App a -> IO a 47 | runApp = unSubsystem 48 | 49 | logged :: Logger () 50 | logged = logMessage Info "a" 51 | 52 | printRandomFactorial' :: App () 53 | printRandomFactorial' = do 54 | n <- getRandomInt (1, 100) 55 | logInfo $ show $ product [1..n] 56 | logMessage Info "b" 57 | subsystem logged 58 | -------------------------------------------------------------------------------- /custom-type-equality-errors/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE ExplicitForAll #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE StandaloneKindSignatures #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | 11 | module Main where 12 | 13 | import Data.Kind 14 | import Data.Type.Map 15 | import GHC.TypeLits 16 | 17 | type CheckEqualKV :: forall k v. k -> k -> v -> v -> Constraint 18 | type family CheckEqualKV k1 k2 v1 v2 where 19 | CheckEqualKV k1 k1 v1 v1 = () 20 | CheckEqualKV k1 k1 v1 v2 = 21 | TypeError 22 | ( 'ShowType v1 ':<>: 23 | 'Text " is not equal to " ':<>: 24 | 'ShowType v2 ':<>: 25 | 'Text " at " ':<>: 26 | 'ShowType k1 27 | ) 28 | CheckEqualKV k1 k2 v1 v2 = 29 | TypeError 30 | ( 'ShowType (k1 ':-> v1) ':<>: 31 | 'Text " is not equal to " ':<>: 32 | 'ShowType (k2 ':-> v2) 33 | ) 34 | 35 | type EqualKV :: forall k v. k -> k -> v -> v -> Constraint 36 | class (k1 ~ k2, v1 ~ v2) => EqualKV k1 k2 v1 v2 37 | instance (CheckEqualKV k1 k2 v1 v2, k1 ~ k2, v1 ~ v2) => EqualKV k1 k2 v1 v2 38 | 39 | -- Ext :: Var k -> v -> Map m -> Map ((k :-> v) ': m) 40 | ext :: EqualKV k1 k2 v1 v2 => Var k1 -> v1 -> Map m -> Map ((k2 ':-> v2) ': m) 41 | ext = Ext 42 | 43 | -- error: 44 | -- • "w" ':-> Bool is not equal to "w" ':-> Int 45 | -- • In the expression: ext (Var :: (Var "w")) False 46 | -- <...> 47 | foo :: Map '["x" ':-> Int, "z" ':-> Bool, "w" ':-> Int] 48 | foo = ext (Var :: (Var "x")) 2 49 | $ ext (Var :: (Var "z")) True 50 | $ ext (Var :: (Var "w")) False 51 | $ Empty 52 | 53 | -- >>> :t bar 54 | -- bar :: Map '[ "x" ':-> Int, "z" ':-> Bool, "w" ':-> Int] 55 | bar = ext (Var :: (Var "x")) (2 :: Int) 56 | $ ext (Var :: (Var "z")) True 57 | $ ext (Var :: (Var "w")) (5 :: Int) 58 | $ Empty 59 | 60 | main :: IO () 61 | main = mempty 62 | -------------------------------------------------------------------------------- /hierarchical-free-monads-mostly-pointless/src/HFM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTSyntax #-} 2 | 3 | module HFM where 4 | 5 | import Control.Monad.Free 6 | import System.Random 7 | 8 | data LogLevel = Info 9 | type Message = String 10 | 11 | -- Algebra (interface) for the LoggerL Free monadic language with only 1 method 12 | data LoggerF next where 13 | LogMessage :: LogLevel -> Message -> (() -> next) -> LoggerF next 14 | 15 | -- Functor instance needed for the Free machinery 16 | instance Functor LoggerF where 17 | fmap f (LogMessage lvl msg next) = LogMessage lvl msg (f . next) 18 | 19 | -- Free monadic language 20 | type Logger a = Free LoggerF a 21 | 22 | data AppF next where 23 | GetRandomInt :: (Int, Int) -> (Int -> next) -> AppF next 24 | EvalLogger :: Logger () -> (() -> next) -> AppF next 25 | 26 | instance Functor AppF where 27 | fmap f (GetRandomInt range next) = GetRandomInt range (f . next) 28 | fmap f (EvalLogger logAct next) = EvalLogger logAct (f . next) 29 | 30 | type App a = Free AppF a 31 | 32 | -- Simple console logger 33 | interpretLoggerF :: LoggerF a -> IO a 34 | interpretLoggerF (LogMessage lvl msg next) = do 35 | putStrLn msg 36 | pure $ next () 37 | 38 | runLogger :: Logger a -> IO a 39 | runLogger = foldFree interpretLoggerF 40 | 41 | -- Interpreting function 42 | interpretAppF :: AppF a -> IO a 43 | interpretAppF (EvalLogger loggerAct next) = next <$> runLogger loggerAct 44 | interpretAppF (GetRandomInt range next) = next <$> randomRIO range 45 | 46 | -- Interpreter entry point 47 | runApp :: App a -> IO a 48 | runApp = foldFree interpretAppF 49 | 50 | -- Log message with Info level. 51 | logInfo :: Message -> App () 52 | logInfo msg = evalLogger (logMessage Info msg) 53 | 54 | -- Helper function to wrap LoggerF method 55 | logMessage :: LogLevel -> Message -> Logger () 56 | logMessage lvl msg = liftF $ LogMessage lvl msg id 57 | 58 | -- Helper function to wrap AppF method 59 | evalLogger :: Logger () -> App () 60 | evalLogger logger = liftF $ EvalLogger logger id 61 | 62 | getRandomInt :: (Int, Int) -> App Int 63 | getRandomInt range = liftF $ GetRandomInt range id 64 | 65 | printRandomFactorial :: App () 66 | printRandomFactorial = do 67 | n <- getRandomInt (1, 100) 68 | logInfo $ show $ product [1..n] 69 | -------------------------------------------------------------------------------- /lazy-reverse/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/configure/yaml/ 6 | 7 | # A 'specific' Stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # snapshot: lts-23.14 12 | # snapshot: nightly-2025-02-15 13 | # snapshot: ghc-9.8.4 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # snapshot: ./custom-snapshot.yaml 19 | # snapshot: https://example.com/snapshots/2024-01-01.yaml 20 | snapshot: lts-23.7 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # subdirs: 29 | # - auto-update 30 | # - wai 31 | packages: 32 | - . 33 | # Dependency packages to be pulled from upstream that are not in the snapshot. 34 | # These entries can reference officially published versions as well as 35 | # forks / in-progress versions pinned to a git hash. For example: 36 | # 37 | # extra-deps: 38 | # - acme-missiles-0.3 39 | # - git: https://github.com/commercialhaskell/stack.git 40 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 41 | # 42 | # extra-deps: [] 43 | 44 | # Override default flag values for project packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of Stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=3.5" 56 | # 57 | # Override the architecture used by Stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by Stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | -------------------------------------------------------------------------------- /better-syntax-for-eDSLs/src/Scoped.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | {-# LANGUAGE ConstraintKinds #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE MagicHash #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE OverloadedRecordDot #-} 11 | {-# LANGUAGE PolyKinds #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE StandaloneKindSignatures #-} 14 | {-# LANGUAGE TypeApplications #-} 15 | {-# LANGUAGE TypeFamilies #-} 16 | {-# LANGUAGE TypeOperators #-} 17 | {-# LANGUAGE UndecidableInstances #-} 18 | 19 | module Scoped where 20 | 21 | import Common 22 | 23 | import GHC.TypeLits 24 | import GHC.Records 25 | import GHC.Exts 26 | import Unsafe.Coerce (UnsafeEquality (..), unsafeEqualityProof) 27 | 28 | type IsScoped :: Symbol -> () 29 | type family IsScoped name 30 | 31 | type InScope name = IsScoped name ~ '() 32 | 33 | data Enter name where 34 | Enter :: InScope name => Enter name 35 | 36 | -- @res ~ (InScope name => Term -> Term)@ doesn't work. 37 | instance (res ~ ((Enter name -> Term) -> Term), KnownSymbol name) => 38 | HasField name (Prefix "lam") res where 39 | getField _ k = 40 | case unsafeEqualityProof @(IsScoped name) @'() of 41 | UnsafeRefl -> Lam (symbolVal' (proxy# @name)) $ k Enter 42 | 43 | type FreeVariableError :: Symbol -> Constraint 44 | type family FreeVariableError name where 45 | FreeVariableError name = 46 | TypeError ('Text "Can't reference a free variable: ‘" :<>: 'Text name :<>: 'Text "’") 47 | 48 | type ThrowOnFree :: Constraint -> () -> Constraint 49 | type family ThrowOnFree err scoped where 50 | ThrowOnFree _ '() = () 51 | ThrowOnFree err _ = err 52 | 53 | instance (res ~ Term, KnownSymbol name, ThrowOnFree (FreeVariableError name) (IsScoped name)) => 54 | HasField name (Prefix "var") res where 55 | getField _ = Var $ symbolVal' (proxy# @name) 56 | 57 | -- >>> print owl 58 | -- Lam "f" (Lam "g" (App (Var "g") (App (Var "f") (Var "g")))) 59 | owl :: Term 60 | owl = lam.f $ \Enter -> lam.g $ \Enter -> app var.g (app var.f var.g) 61 | 62 | -- -- error: [GHC-64725] 63 | -- -- • Can't reference a free variable: ‘x’ 64 | -- -- • In the expression: var.x 65 | -- -- In an equation for ‘free’: free = var.x 66 | -- free :: Term 67 | -- free = var.x 68 | -------------------------------------------------------------------------------- /mineunifier/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-18.19 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # subdirs: 29 | # - auto-update 30 | # - wai 31 | packages: 32 | - . 33 | # Dependency packages to be pulled from upstream that are not in the resolver. 34 | # These entries can reference officially published versions as well as 35 | # forks / in-progress versions pinned to a git hash. For example: 36 | # 37 | # extra-deps: 38 | # - acme-missiles-0.3 39 | # - git: https://github.com/commercialhaskell/stack.git 40 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 41 | # 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=2.7" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | -------------------------------------------------------------------------------- /a-law-breaking-hack/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-13.26 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # subdirs: 29 | # - auto-update 30 | # - wai 31 | packages: 32 | - . 33 | # Dependency packages to be pulled from upstream that are not in the resolver. 34 | # These entries can reference officially published versions as well as 35 | # forks / in-progress versions pinned to a git hash. For example: 36 | # 37 | # extra-deps: 38 | # - acme-missiles-0.3 39 | # - git: https://github.com/commercialhaskell/stack.git 40 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 41 | # 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=2.3" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | -------------------------------------------------------------------------------- /custom-warning-hack/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-17.2 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # subdirs: 29 | # - auto-update 30 | # - wai 31 | packages: 32 | - . 33 | # Dependency packages to be pulled from upstream that are not in the resolver. 34 | # These entries can reference officially published versions as well as 35 | # forks / in-progress versions pinned to a git hash. For example: 36 | # 37 | # extra-deps: 38 | # - acme-missiles-0.3 39 | # - git: https://github.com/commercialhaskell/stack.git 40 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 41 | # 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=2.5" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | -------------------------------------------------------------------------------- /generalizing-unliftio/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-17.2 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # subdirs: 29 | # - auto-update 30 | # - wai 31 | packages: 32 | - . 33 | # Dependency packages to be pulled from upstream that are not in the resolver. 34 | # These entries can reference officially published versions as well as 35 | # forks / in-progress versions pinned to a git hash. For example: 36 | # 37 | # extra-deps: 38 | # - acme-missiles-0.3 39 | # - git: https://github.com/commercialhaskell/stack.git 40 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 41 | # 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=2.5" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | -------------------------------------------------------------------------------- /things-you-should-avoid/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-13.26 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # subdirs: 29 | # - auto-update 30 | # - wai 31 | packages: 32 | - . 33 | # Dependency packages to be pulled from upstream that are not in the resolver. 34 | # These entries can reference officially published versions as well as 35 | # forks / in-progress versions pinned to a git hash. For example: 36 | # 37 | # extra-deps: 38 | # - acme-missiles-0.3 39 | # - git: https://github.com/commercialhaskell/stack.git 40 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 41 | # 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=2.3" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | -------------------------------------------------------------------------------- /better-counterexample-minimization/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-21.13 12 | # resolver: nightly-2023-09-24 13 | # resolver: ghc-9.6.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2023-01-01.yaml 20 | resolver: lts-23.7 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # subdirs: 29 | # - auto-update 30 | # - wai 31 | packages: 32 | - . 33 | # Dependency packages to be pulled from upstream that are not in the resolver. 34 | # These entries can reference officially published versions as well as 35 | # forks / in-progress versions pinned to a git hash. For example: 36 | # 37 | # extra-deps: 38 | # - acme-missiles-0.3 39 | # - git: https://github.com/commercialhaskell/stack.git 40 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 41 | # 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of Stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=2.13" 56 | # 57 | # Override the architecture used by Stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by Stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | -------------------------------------------------------------------------------- /poly-type-of-saga/part1-try-unify/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: nightly-2020-08-17 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # subdirs: 29 | # - auto-update 30 | # - wai 31 | packages: 32 | - . 33 | # Dependency packages to be pulled from upstream that are not in the resolver. 34 | # These entries can reference officially published versions as well as 35 | # forks / in-progress versions pinned to a git hash. For example: 36 | # 37 | # extra-deps: 38 | # - acme-missiles-0.3 39 | # - git: https://github.com/commercialhaskell/stack.git 40 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 41 | # 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=2.3" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | -------------------------------------------------------------------------------- /poly-type-of-saga/part2-enumerate-type-vars/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: nightly-2020-08-17 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # subdirs: 29 | # - auto-update 30 | # - wai 31 | packages: 32 | - . 33 | # Dependency packages to be pulled from upstream that are not in the resolver. 34 | # These entries can reference officially published versions as well as 35 | # forks / in-progress versions pinned to a git hash. For example: 36 | # 37 | # extra-deps: 38 | # - acme-missiles-0.3 39 | # - git: https://github.com/commercialhaskell/stack.git 40 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 41 | # 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=2.3" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | -------------------------------------------------------------------------------- /validation-leak/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-9.17 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - . 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.5" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /better-syntax-for-eDSLs/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: 21 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/22.yaml 22 | 23 | # User packages to be built. 24 | # Various formats can be used as shown in the example below. 25 | # 26 | # packages: 27 | # - some-directory 28 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 29 | # subdirs: 30 | # - auto-update 31 | # - wai 32 | packages: 33 | - . 34 | # Dependency packages to be pulled from upstream that are not in the resolver. 35 | # These entries can reference officially published versions as well as 36 | # forks / in-progress versions pinned to a git hash. For example: 37 | # 38 | # extra-deps: 39 | # - acme-missiles-0.3 40 | # - git: https://github.com/commercialhaskell/stack.git 41 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 42 | # 43 | # extra-deps: [] 44 | 45 | # Override default flag values for local packages and extra-deps 46 | # flags: {} 47 | 48 | # Extra package databases containing global packages 49 | # extra-package-dbs: [] 50 | 51 | # Control whether we use the GHC we find on the path 52 | # system-ghc: true 53 | # 54 | # Require a specific version of Stack, using version ranges 55 | # require-stack-version: -any # Default 56 | # require-stack-version: ">=2.11" 57 | # 58 | # Override the architecture used by Stack, especially useful on Windows 59 | # arch: i386 60 | # arch: x86_64 61 | # 62 | # Extra directories used by Stack for building 63 | # extra-include-dirs: [/path/to/dir] 64 | # extra-lib-dirs: [/path/to/dir] 65 | # 66 | # Allow a newer minor version of GHC than the snapshot specifies 67 | # compiler-check: newer-minor 68 | -------------------------------------------------------------------------------- /generalizing-unliftio/src/Peel.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | module Peel where 7 | 8 | import SomeAction 9 | import Unlift 10 | 11 | import Control.Monad.Except 12 | import Control.Monad.Morph 13 | import Control.Monad.Trans.Reader 14 | import Data.Functor.Identity 15 | 16 | -- -- We could also always unlift whenever we peel, it's not clear to me what the trade-offs are. 17 | 18 | -- class (MonadUnliftable (Peel m), Monad m) => MonadPeelable m where 19 | -- type Peel m :: * -> * 20 | -- withPeel :: ((forall a. Peel m a -> Unlift (Peel m) a) -> Unlift (Peel m) r) -> m r 21 | 22 | -- forkP :: (MonadPeel p m, MonadUnlift IO p) => p () -> m ThreadId 23 | -- forkP a = withPeel $ \peel -> forkIO $ peel a 24 | 25 | class (Monad (Peel m), Monad m) => MonadPeelable m where 26 | type Peel m :: * -> * 27 | liftP :: Peel m a -> m a 28 | 29 | instance MonadPeelable IO where 30 | type Peel IO = IO 31 | liftP = id 32 | 33 | instance MonadPeelable Identity where 34 | type Peel Identity = Identity 35 | liftP = id 36 | 37 | instance MonadPeelable m => MonadPeelable (ReaderT r m) where 38 | type Peel (ReaderT r m) = ReaderT r (Peel m) 39 | liftP = hoist liftP 40 | 41 | instance MonadPeelable m => MonadPeelable (ExceptT e m) where 42 | type Peel (ExceptT e m) = Peel m 43 | liftP = lift . liftP 44 | 45 | type MonadPeel p m = (MonadPeelable m, Peel m ~ p) 46 | 47 | instance MonadPeelable App where 48 | type Peel App = App 49 | liftP = id 50 | 51 | instance MonadPeelable m => MonadPeelable (AppT m) where 52 | type Peel (AppT m) = AppT (Peel m) 53 | liftP = hoist liftP 54 | 55 | testAppG 56 | :: ( MonadUnlift b m, MonadError () b 57 | , MonadPeel p m 58 | , MonadUnlift IO p 59 | , SomeAction p 60 | , MonadIO m 61 | ) 62 | => m () 63 | testAppG = throwErrorU () `catchErrorU` \() -> do -- MonadUnlift b m, MonadError () b 64 | _ <- 65 | liftP $ -- MonadPeel p m 66 | forkU $ -- MonadUnlift IO p 67 | someAction -- SomeAction p 68 | printM () -- MonadIO m 69 | 70 | testApp :: ExceptT () App () 71 | testApp = testAppG 72 | 73 | testAppT :: AppT (ExceptT () IO) () 74 | testAppT = testAppG 75 | -------------------------------------------------------------------------------- /exhaustive-unordered-pattern-matching/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: 21 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/22.yaml 22 | 23 | # User packages to be built. 24 | # Various formats can be used as shown in the example below. 25 | # 26 | # packages: 27 | # - some-directory 28 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 29 | # subdirs: 30 | # - auto-update 31 | # - wai 32 | packages: 33 | - . 34 | # Dependency packages to be pulled from upstream that are not in the resolver. 35 | # These entries can reference officially published versions as well as 36 | # forks / in-progress versions pinned to a git hash. For example: 37 | # 38 | # extra-deps: 39 | # - acme-missiles-0.3 40 | # - git: https://github.com/commercialhaskell/stack.git 41 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 42 | # 43 | # extra-deps: [] 44 | 45 | # Override default flag values for local packages and extra-deps 46 | # flags: {} 47 | 48 | # Extra package databases containing global packages 49 | # extra-package-dbs: [] 50 | 51 | # Control whether we use the GHC we find on the path 52 | # system-ghc: true 53 | # 54 | # Require a specific version of Stack, using version ranges 55 | # require-stack-version: -any # Default 56 | # require-stack-version: ">=2.11" 57 | # 58 | # Override the architecture used by Stack, especially useful on Windows 59 | # arch: i386 60 | # arch: x86_64 61 | # 62 | # Extra directories used by Stack for building 63 | # extra-include-dirs: [/path/to/dir] 64 | # extra-lib-dirs: [/path/to/dir] 65 | # 66 | # Allow a newer minor version of GHC than the snapshot specifies 67 | # compiler-check: newer-minor 68 | -------------------------------------------------------------------------------- /trouble-in-paradise-fibonacci/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | {-# LANGUAGE BangPatterns #-} 4 | 5 | module Main where 6 | 7 | import Data.List 8 | import NoThunks.Class 9 | import System.Environment 10 | 11 | fibs_zw :: [Integer] 12 | fibs_zw = 0 : 1 : zipWith (+) fibs_zw (tail fibs_zw) 13 | 14 | fib_zw :: Int -> Integer 15 | fib_zw n = fibs_zw !! n 16 | 17 | infix 4 `cons'` 18 | cons' :: a -> [a] -> [a] 19 | cons' !x xs = x : xs 20 | 21 | at' :: Int -> [a] -> a 22 | at' n0 | n0 < 0 = error "bad index" 23 | at' n0 = go n0 where 24 | go _ [] = error "not enough elements" 25 | go 0 (x:_) = x 26 | go n ((!_):xs) = go (n - 1) xs 27 | 28 | fib_zw1' :: Int -> Integer 29 | fib_zw1' n = at' n fibs_zw 30 | 31 | zipWith' :: (a -> b -> c) -> [a] -> [b] -> [c] 32 | zipWith' f = go where 33 | go (x : xs) (y : ys) = f x y `cons'` go xs ys 34 | go _ _ = [] 35 | 36 | fibs_zw' :: [Integer] 37 | fibs_zw' = 0 : 1 : zipWith' (+) fibs_zw (tail fibs_zw) 38 | 39 | fib_zw2' :: Int -> Integer 40 | fib_zw2' n = fibs_zw' !! n 41 | 42 | fibs_sl' :: [Integer] 43 | fibs_sl' = 0 : scanl' (+) 1 fibs_sl' 44 | 45 | fib_sl' :: Int -> Integer 46 | fib_sl' n = fibs_sl' !! n 47 | 48 | forceElems :: [a] -> [a] 49 | forceElems = foldr cons' [] 50 | 51 | fib_zwfe :: Int -> Integer 52 | fib_zwfe n = forceElems fibs_zw !! n 53 | 54 | fib_loop :: Int -> Integer 55 | fib_loop n0 = go n0 0 1 where 56 | go 0 curr _ = curr 57 | go n curr next = go (n - 1) next $! curr + next 58 | 59 | throwOnThunks :: NoThunks a => a -> a 60 | throwOnThunks x = case unsafeNoThunks x of 61 | Nothing -> x 62 | Just _ -> error "A thunk!" 63 | 64 | thunkElemsToErrorsLazy :: NoThunks a => [a] -> [a] 65 | thunkElemsToErrorsLazy = map throwOnThunks 66 | 67 | thunkElemsToErrors :: NoThunks a => [a] -> [a] 68 | thunkElemsToErrors = forceElems . thunkElemsToErrorsLazy 69 | 70 | unsafeFib_zw :: Int -> Integer 71 | unsafeFib_zw n = thunkElemsToErrors fibs_zw !! n 72 | 73 | unsafeFib_zw1' :: Int -> Integer 74 | unsafeFib_zw1' n = thunkElemsToErrors fibs_zw' !! n 75 | 76 | unsafeFib_zwfe :: Int -> Integer 77 | unsafeFib_zwfe n = thunkElemsToErrors (forceElems fibs_zw) !! n 78 | 79 | main :: IO () 80 | main = do 81 | [mode] <- getArgs 82 | let run = print . length . show 83 | case mode of 84 | "zw" -> run $ fib_zw 500000 85 | "zw1s" -> run $ fib_zw1' 500000 86 | "zw2s" -> run $ fib_zw2' 500000 87 | "sls" -> run $ fib_sl' 500000 88 | "zwfe" -> run $ fib_zwfe 500000 89 | "zw_nothunks" -> run $ unsafeFib_zw 500000 90 | "zw1s_nothunks" -> run $ unsafeFib_zw1' 500000 91 | "zwfe_nothunks" -> run $ unsafeFib_zwfe 500000 92 | "zw2s_2" -> do 93 | run $ fib_zw2' 100000 94 | run $ fib_zw2' 99999 95 | "loop" -> do 96 | run $ fib_loop 100000 97 | run $ fib_loop 99999 98 | _ -> fail "wrong mode" 99 | -------------------------------------------------------------------------------- /mineunifier/src/Mineunifier/IO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | 12 | module Mineunifier.IO where 13 | 14 | import Mineunifier.Core 15 | 16 | import Data.Proxy 17 | import GHC.TypeLits 18 | import Data.Type.Equality 19 | 20 | class Parse source result 21 | instance Parse "?" c 22 | instance c ~~ 'X => Parse "x" c 23 | instance c ~~ 'N (FromNat 0) => Parse "0" c 24 | instance c ~~ 'N (FromNat 1) => Parse "1" c 25 | instance c ~~ 'N (FromNat 2) => Parse "2" c 26 | instance c ~~ 'N (FromNat 3) => Parse "3" c 27 | instance c ~~ 'N (FromNat 4) => Parse "4" c 28 | instance c ~~ 'N (FromNat 5) => Parse "5" c 29 | instance c ~~ 'N (FromNat 6) => Parse "6" c 30 | instance c ~~ 'N (FromNat 7) => Parse "7" c 31 | instance c ~~ 'N (FromNat 8) => Parse "8" c 32 | instance result ~~ '[] => Parse '[] result 33 | instance (Parse s r, Parse ss' rs', rs ~~ (r ': rs')) => Parse (s ': ss') rs 34 | 35 | class DisplayGamey a where 36 | displayGamey :: String 37 | 38 | instance DisplayGamey 'X where 39 | displayGamey = "x" 40 | 41 | instance KnownNat (ToNat m) => DisplayGamey ('N m) where 42 | displayGamey = show . natVal $ Proxy @(ToNat m) 43 | 44 | instance DisplayGamey '[] where 45 | displayGamey = "" 46 | 47 | instance (DisplayGamey el, DisplayGamey row) => DisplayGamey (el ': row :: [Cell]) where 48 | displayGamey = displayGamey @el ++ " " ++ displayGamey @row 49 | 50 | instance (DisplayGamey row, DisplayGamey rows) => DisplayGamey (row ': rows :: [[Cell]]) where 51 | displayGamey = displayGamey @row ++ "\n" ++ displayGamey @rows 52 | 53 | displayBoard :: forall input result. (Parse input result, DisplayGamey result) => String 54 | displayBoard = displayGamey @result 55 | 56 | -- >>> :set -XDataKinds 57 | -- >>> :set -XTypeApplications 58 | -- >>> putStrLn $ displayBoard @('[ ["1", "1", "0"], ["x", "1", "0"] ]) 59 | -- 1 1 0 60 | -- x 1 0 61 | -- >>> putStrLn $ displayBoard @('[ ["1", "1", "0"], ["?", "1", "0"] ]) 62 | -- :546:13: error: 63 | -- • Ambiguous type variable ‘r0’ arising from a use of ‘displayBoard’ 64 | -- prevents the constraint ‘(DisplayGamey r0)’ from being solved. 65 | -- Probable fix: use a type annotation to specify what ‘r0’ should be. 66 | -- These potential instances exist: 67 | -- instance [safe] KnownNat (ToNat m) => DisplayGamey ('N m) 68 | -- -- Defined at /tmp/danteoGX7Hm.hs:41:10 69 | -- instance [safe] DisplayGamey 'X 70 | -- -- Defined at /tmp/danteoGX7Hm.hs:38:10 71 | -- • In the second argument of ‘($)’, namely 72 | -- ‘displayBoard @('[["1", "1", "0"], ["?", "1", "0"]])’ 73 | -- In the expression: 74 | -- putStrLn $ displayBoard @('[["1", "1", "0"], ["?", "1", "0"]]) 75 | -- In an equation for ‘it’: 76 | -- it = putStrLn $ displayBoard @('[["1", "1", "0"], ["?", "1", "0"]]) 77 | -------------------------------------------------------------------------------- /things-you-should-avoid/README.md: -------------------------------------------------------------------------------- 1 | # Things you should avoid 2 | 3 | Disclaimer: don't take it too seriously. 4 | 5 | Some things are to be avoided. Let's look at a few examples in the Haskell land. Since there are going to be a few of them, it's natural to introduce a type class: 6 | 7 | ```haskell 8 | -- | Things to be avoided. 9 | class Avoid a where 10 | avoid :: a -> void 11 | ``` 12 | 13 | If you don't know what `void` means, check out [To Void or to void](https://tech.fpcomplete.com/blog/2017/07/to-void-or-to-void). 14 | 15 | One thing that you definitely should avoid is any kind of false. For one example: 16 | 17 | ```haskell 18 | data False 19 | 20 | instance Avoid False where 21 | avoid = \case{} 22 | ``` 23 | 24 | For another: 25 | 26 | ```haskell 27 | data AnythingIsTrue = AnythingIsTrue (forall a. a) 28 | instance Avoid AnythingIsTrue where 29 | avoid (AnythingIsTrue void) = void 30 | ``` 31 | 32 | Don't be fooled by the [marketing](http://inutile.club/estatis/falso)! 33 | 34 | Infinite loops are to be avoided as well. Both type-level: 35 | 36 | ```haskell 37 | newtype TypeLevelLoop = TypeLevelLoop TypeLevelLoop 38 | 39 | instance Avoid TypeLevelLoop where 40 | avoid (TypeLevelLoop loop) = avoid loop 41 | ``` 42 | 43 | and term-level ones: 44 | 45 | ```haskell 46 | data TermLevelLoop = TermLevelLoop 47 | 48 | instance Avoid TermLevelLoop where 49 | avoid = avoid 50 | ``` 51 | 52 | Exceptions? Avoid! 53 | 54 | ```haskell 55 | data Exception = Exception 56 | 57 | instance Avoid Exception where 58 | avoid Exception = error "You should have avoided this" 59 | ``` 60 | 61 | There's no place for incomplete implementations: 62 | 63 | ```haskell 64 | data IncompleteImplementation = IncompleteImplementation 65 | 66 | instance Avoid IncompleteImplementation 67 | ``` 68 | 69 | Avoid any kind of unsafety. For one example, `unsafeCoerce`. Or at least don't make it worse with overlapping instances: 70 | 71 | ```haskell 72 | instance {-# OVERLAPPABLE #-} Avoid a where 73 | avoid = unsafeCoerce 74 | ``` 75 | 76 | For another example, `unsafePerformIO`: 77 | 78 | ```haskell 79 | data UnsafePerformIO = UnsafePerformIO 80 | 81 | instance Avoid UnsafePerformIO where 82 | avoid UnsafePerformIO = 83 | unsafePerformIO . forever $ putStrLn "I will not use 'unsafePerformIO' anymore" 84 | ``` 85 | 86 | False promises are not to be tolerated: 87 | 88 | ```haskell 89 | newtype FalsePromise a = FalsePromise (Avoid a => a) 90 | instance Avoid (FalsePromise a) where 91 | avoid (FalsePromise x) = avoid x 92 | ``` 93 | 94 | Finally, every success has a cost 95 | 96 | ```haskell 97 | newtype Success cost = Success cost 98 | ``` 99 | 100 | so most importantly, avoid success at all costs! 101 | 102 | ```haskell 103 | newtype AtAllCosts f = AtAllCosts 104 | { unAtAllCosts :: forall cost. f cost 105 | } 106 | 107 | instance Avoid (AtAllCosts Success) where 108 | avoid (AtAllCosts (Success void)) = void 109 | ``` 110 | 111 | Bonus: [this article should be avoided](https://www.reddit.com/r/haskell/comments/j55bk6/things_you_should_avoid/g7rmggo/). 112 | -------------------------------------------------------------------------------- /mineunifier/src/Mineunifier/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE PolyKinds #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | 11 | module Mineunifier.Core where 12 | 13 | import Mineunifier.Util 14 | 15 | import Data.Kind 16 | import GHC.TypeLits 17 | 18 | data Peano = Z | S Peano 19 | 20 | type family FromNat (n :: Nat) :: Peano where 21 | FromNat 0 = 'Z 22 | FromNat n = 'S (FromNat (n - 1)) 23 | 24 | type family ToNat (m :: Peano) :: Nat where 25 | ToNat 'Z = 0 26 | ToNat ('S m) = ToNat m + 1 27 | 28 | -------------------- 29 | 30 | data Cell 31 | = X 32 | | N Peano 33 | 34 | -------------------- 35 | 36 | class Rule (n :: a) (c :: Cell) (p :: a) 37 | 38 | instance {-# INCOHERENT #-} n ~ 'S p => Rule n 'X p 39 | instance {-# INCOHERENT #-} n ~ p => Rule n ('N m) p 40 | 41 | instance {-# INCOHERENT #-} (n' ~ 'Z, c ~ 'X) => Rule ('S n') c 'Z 42 | instance {-# INCOHERENT #-} (c ~ 'N m, p ~ 'Z) => Rule 'Z c p 43 | 44 | instance {-# INCOHERENT #-} (p ~ 'S p', Rule ('S n') c p') => Rule ('S ('S n')) c p 45 | instance {-# INCOHERENT #-} (n ~ 'S n', Rule n' c p') => Rule n c ('S p') 46 | 47 | -------------------- 48 | 49 | class NeighbsToRulesGo (n :: Peano) (nb :: Cell) (nbs :: [Cell]) 50 | instance Rule n nb 'Z => NeighbsToRulesGo n nb '[] 51 | instance (Rule n nb n', NeighbsToRulesGo n' nb' nbs) => NeighbsToRulesGo n nb (nb' ': nbs) 52 | 53 | type family NeighbsToRules (c :: Cell) (nbs :: [Cell]) :: Constraint where 54 | NeighbsToRules 'X _ = () 55 | NeighbsToRules ('N n) '[] = n ~ 'Z 56 | NeighbsToRules ('N n) (nb ': nbs) = NeighbsToRulesGo n nb nbs 57 | 58 | -------------------- 59 | 60 | type family MakeRulesRow ss ps cs ns :: Constraint where 61 | MakeRulesRow _ _ '[] _ = () 62 | MakeRulesRow ss ps (c ': cs) ns = 63 | ( NeighbsToRules c (Take 3 ss ++ Take 2 ps ++ Take 1 cs ++ Take 2 ns) 64 | , MakeRulesRow (Take 1 ps ++ '[c] ++ Take 1 ns) (Drop 1 ps) cs (Drop 1 ns) 65 | ) 66 | 67 | type family MakeRulesGo ps (css :: [[Cell]]) :: Constraint where 68 | MakeRulesGo _ '[] = () 69 | MakeRulesGo ps (cs ': css) = 70 | ( MakeRulesRow '[] ps cs (HeadDef '[] css) 71 | , MakeRulesGo cs css 72 | ) 73 | 74 | type MakeRules result = MakeRulesGo '[] result 75 | 76 | -------------------- 77 | 78 | class Reveal (answer :: a) (puzzle :: a) 79 | instance answer ~ 'X => Reveal answer 'X 80 | instance answer ~ 'N p => Reveal answer ('N p) 81 | instance answer ~ '[] => Reveal answer '[] 82 | instance (as ~ (a ': as'), Reveal a p, Reveal as' ps') => Reveal as (p ': ps') 83 | 84 | type family CountXs (a :: k) :: Nat where 85 | CountXs 'X = 1 86 | CountXs (y ': ys) = CountXs y + CountXs ys 87 | CountXs _ = 0 88 | 89 | class Verify (answer :: [[Cell]]) (puzzle :: [[Cell]]) 90 | instance 91 | ( Reveal answer puzzle 92 | , NeighbsToRules ('N (FromNat (CountXs answer))) (Concat puzzle) 93 | ) => Verify answer puzzle 94 | -------------------------------------------------------------------------------- /generalizing-unliftio/src/Unlift.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | module Unlift where 11 | 12 | import SomeAction 13 | 14 | import Control.Concurrent 15 | import Control.Monad.Except 16 | import Control.Monad.Morph 17 | import Control.Monad.ST 18 | import Control.Monad.Trans.Identity 19 | import Control.Monad.Trans.Reader 20 | import Data.Functor.Identity 21 | 22 | -- class (Monad b, Monad m) => MonadUnlift b m | m -> b where 23 | -- withUnlift :: ((forall a. m a -> b a) -> b r) -> m r 24 | 25 | class (Monad (Unlift m), Monad m) => MonadUnliftable m where 26 | type Unlift m :: * -> * 27 | withUnlift :: ((forall a. m a -> Unlift m a) -> Unlift m r) -> m r 28 | 29 | instance MonadUnliftable IO where 30 | type Unlift IO = IO 31 | withUnlift k = k id 32 | 33 | instance MonadUnliftable m => MonadUnliftable (ReaderT r m) where 34 | type Unlift (ReaderT r m) = Unlift m 35 | withUnlift k = ReaderT $ \r -> withUnlift $ \unlift -> k $ unlift . flip runReaderT r 36 | 37 | instance MonadUnliftable (ST s) where 38 | type Unlift (ST s) = ST s 39 | withUnlift k = k id 40 | 41 | instance MonadUnliftable Identity where 42 | type Unlift Identity = Identity 43 | withUnlift k = k id 44 | 45 | instance MonadUnliftable m => MonadUnliftable (IdentityT m) where 46 | type Unlift (IdentityT m) = m 47 | withUnlift k = IdentityT $ k runIdentityT 48 | 49 | instance MonadUnliftable m => MonadUnliftable (ExceptT e m) where 50 | type Unlift (ExceptT e m) = ExceptT e (Unlift m) 51 | withUnlift k = ExceptT $ withUnlift $ \unlift -> runExceptT $ k $ mapExceptT unlift 52 | 53 | type MonadUnlift b m = (MonadUnliftable m, Unlift m ~ b) 54 | 55 | liftU :: MonadUnlift b m => b a -> m a 56 | liftU a = withUnlift $ \_ -> a 57 | 58 | forkU :: MonadUnlift IO m => m () -> m ThreadId 59 | forkU a = withUnlift $ \unlift -> forkIO $ unlift a 60 | 61 | throwErrorU :: (MonadUnlift b m, MonadError e b) => e -> m a 62 | throwErrorU = liftU . throwError 63 | 64 | catchErrorU :: (MonadUnlift b m, MonadError e b) => m a -> (e -> m a) -> m a 65 | a `catchErrorU` f = withUnlift $ \unlift -> unlift a `catchError` (unlift . f) 66 | 67 | newtype App a = App 68 | { unApp :: ReaderT () IO a 69 | } deriving newtype (Functor, Applicative, Monad, MonadIO, MonadUnliftable) 70 | deriving anyclass (SomeAction) 71 | 72 | testApp :: ExceptT () App () 73 | testApp = throwError () `catchError` \() -> do 74 | _ <- lift $ forkU someAction 75 | printM () 76 | 77 | testAppU :: ExceptT () App () 78 | testAppU = throwErrorU () `catchErrorU` \() -> do 79 | _ <- lift $ forkU someAction 80 | printM () 81 | 82 | newtype AppT m a = AppT 83 | { unAppT :: ReaderT () m a 84 | } deriving newtype (Functor, Applicative, Monad, MonadIO, MonadUnliftable, MFunctor) 85 | deriving anyclass (SomeAction) 86 | 87 | testAppT :: AppT (ExceptT () IO) () 88 | testAppT = throwErrorU () `catchErrorU` \() -> do 89 | _ <- hoist lift $ forkU someAction 90 | printM () 91 | -------------------------------------------------------------------------------- /mineunifier/src/Mineunifier/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE AllowAmbiguousTypes #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | 9 | module Mineunifier.Test where 10 | 11 | import Mineunifier.Core 12 | import Mineunifier.Game 13 | import Mineunifier.IO 14 | 15 | play 16 | :: forall number (result :: [[Cell]]). 17 | (Parse (ToSolve number) result, MakeRules result, ToCheck number result, DisplayGamey result) 18 | => IO () 19 | play = do 20 | putStrLn "Solution:" 21 | putStrLn $ displayGamey @result 22 | 23 | -- Solution: 24 | -- 1 1 0 0 0 25 | -- x 2 1 0 0 26 | -- 3 x 1 0 0 27 | -- x 3 1 1 1 28 | -- x 2 0 1 x 29 | -- >>> :set -XDataKinds 30 | -- >>> :set -XTypeApplications 31 | -- >>> play @0 32 | -- Solution: 33 | -- >>> play @1 34 | -- Solution: 35 | -- 0 36 | -- >>> play @2 37 | -- Solution: 38 | -- x 39 | -- >>> play @3 40 | -- Solution: 41 | -- x 1 42 | -- >>> play @4 43 | -- Solution: 44 | -- x x 45 | -- >>> play @5 46 | -- Solution: 47 | -- x x 48 | -- >>> play @6 49 | -- :561:2: error: 50 | -- • Could not deduce: (NeighbsToRules r0 '[r1], 51 | -- NeighbsToRules r1 '[r0]) 52 | -- arising from a use of ‘play’ 53 | -- • In the expression: play @6 54 | -- In an equation for ‘it’: it = play @6 55 | -- :561:2: error: 56 | -- • No instance for (Rule n'0 r1 'Z) arising from a use of ‘play’ 57 | -- • In the expression: play @6 58 | -- In an equation for ‘it’: it = play @6 59 | -- >>> play @7 60 | -- Solution: 61 | -- x x 62 | -- x x 63 | -- >>> play @8 64 | -- :563:2: error: 65 | -- • Could not deduce: (NeighbsToRules r0 '[r1, r2, 'N ('S 'Z)], 66 | -- NeighbsToRules r1 '[r0, r2, 'N ('S 'Z)], 67 | -- NeighbsToRules r2 '[r0, r1, 'N ('S 'Z)]) 68 | -- arising from a use of ‘play’ 69 | -- • In the expression: play @8 70 | -- In an equation for ‘it’: it = play @8 71 | -- :563:2: error: 72 | -- • No instance for (Rule n'2 r1 n'1) arising from a use of ‘play’ 73 | -- • In the expression: play @8 74 | -- In an equation for ‘it’: it = play @8 75 | -- >>> play @9 76 | -- Solution: 77 | -- 1 1 78 | -- x 1 79 | -- >>> play @10 80 | -- Solution: 81 | -- 2 3 2 82 | -- x x x 83 | -- x x 3 84 | -- >>> play @11 85 | -- Solution: 86 | -- x 3 3 2 87 | -- 2 x x x 88 | -- 2 3 4 x 89 | -- x 3 3 2 90 | -- 2 x x 1 91 | -- >>> play @12 92 | -- Solution: 93 | -- 1 2 x x 1 94 | -- 2 x 4 2 1 95 | -- 3 x 3 0 0 96 | -- 2 x 2 0 0 97 | -- 1 1 1 0 0 98 | -- >>> play @13 99 | -- Solution: 100 | -- 0 0 2 x x 101 | -- 0 0 2 x 3 102 | -- 1 1 1 1 1 103 | -- x 2 0 0 0 104 | -- x 2 0 0 0 105 | -- >>> play @14 106 | -- Solution: 107 | -- 0 0 0 2 x 108 | -- 0 0 0 3 x 109 | -- 1 1 0 2 x 110 | -- x 1 0 2 2 111 | -- 1 1 0 1 x 112 | -- >>> play @15 113 | -- Solution: 114 | -- 1 1 0 0 0 115 | -- x 2 1 0 0 116 | -- 3 x 1 0 0 117 | -- x 3 1 1 1 118 | -- x 2 0 1 x 119 | -- >>> play @16 120 | -- Solution: 121 | -- x x x 1 0 0 0 122 | -- 2 3 2 1 0 0 0 123 | -- 0 0 0 0 0 0 0 124 | -- 1 2 1 2 1 1 0 125 | -- x 3 x 2 x 1 0 126 | -- x 5 2 3 1 1 0 127 | -- x 3 x 1 0 0 0 128 | -- >>> play @17 129 | -- Solution: 130 | -- 2 x x 2 1 1 0 131 | -- x 4 2 3 x 2 0 132 | -- x 2 1 3 x 3 1 133 | -- 1 1 2 x 3 2 x 134 | -- 0 0 2 x 2 1 1 135 | -- 0 0 1 1 1 0 0 136 | -- 0 0 0 0 0 0 0 137 | -- >>> play @18 138 | -- Solution: 139 | -- 0 1 x 1 0 0 0 140 | -- 1 3 3 2 0 1 1 141 | -- 1 x x 1 0 2 x 142 | -- 1 2 2 1 0 2 x 143 | -- 1 1 1 1 1 1 1 144 | -- x 2 2 x 1 1 1 145 | -- 2 x 2 1 1 1 x 146 | -------------------------------------------------------------------------------- /custom-warning-hack/README.md: -------------------------------------------------------------------------------- 1 | # A custom warning hack 2 | 3 | This post describes how to hackily set up a helpful warning where you normally wouldn't get it. Full code is in [`src/Main.hs`](./src/Main.hs). 4 | 5 | Consider the following data type: 6 | 7 | ```haskell 8 | data D 9 | = C0 10 | | C1 Int Bool 11 | | C3 Char 12 | ``` 13 | 14 | You might want to parse it: 15 | 16 | ```haskell 17 | parseC0 :: Parse D 18 | parseC1 :: Parse D 19 | parseC3 :: Parse D 20 | 21 | parseD :: Parse D 22 | parseD = parseC0 <|> parseC1 <|> parseC3 23 | ``` 24 | 25 | That works alright, but extending `D` with an additional constructor, say, 26 | 27 | ```haskell 28 | | C2 Word 29 | ``` 30 | 31 | won't trigger any warning about `parseD` not handling this new constructor. Which can be troubling, especially when someone contributes to your codebase and doesn't even know there's a parser to extend. And the same applies to deserialization, decoding from JSON etc. So that problem does appear in the wild. Tests should normally catch it, but proper tests are not always there and staring at failed tests and trying to make sense of what just happened is more expensive than preventing them from failing in the first place. 32 | 33 | Ideally, it would be nice to have some kind of cocoverage checking, so that we could write something like 34 | 35 | ```haskell 36 | parseD :: Parse Dn 37 | C0{} <- parseD = parseC0 38 | C1{} <- parseD = parseC1 39 | C3{} <- parseD = parseC3 40 | ``` 41 | 42 | meaning "try `parseC0` and if that fails or doesn't return a `C0`, then try `parseC1` etc", which would allow the compiler to check that all the constructors are mentioned to the left of the `->`s. 43 | 44 | But we don't have any of that and so we can simply introduce a separate function matching on all the constructors of the data type and turning the regular incomplete patterns warning into something a bit more suggestive: 45 | 46 | ```haskell 47 | 48 | class Warning warning where 49 | warning :: warning -> () 50 | 51 | data FIX_ME_BUT_FIRST request a 52 | = LOOK_RIGHT_ABOVE 53 | | FIX_ME_BUT_FIRST request a 54 | 55 | data IMPLEMENT_PARSING_FOR = IMPLEMENT_PARSING_FOR 56 | 57 | instance Warning (FIX_ME_BUT_FIRST IMPLEMENT_PARSING_FOR D) where 58 | warning LOOK_RIGHT_ABOVE = () 59 | warning (FIX_ME_BUT_FIRST IMPLEMENT_PARSING_FOR C0{}) = () 60 | warning (FIX_ME_BUT_FIRST IMPLEMENT_PARSING_FOR C1{}) = () 61 | warning (FIX_ME_BUT_FIRST IMPLEMENT_PARSING_FOR C3{}) = () 62 | ``` 63 | 64 | Now adding the `C2` constructor to `D` gives us the following warning when type checking `warning`: 65 | 66 | ``` 67 | .../custom-warning-hack/src/Main.hs:34:3: warning: [-Wincomplete-patterns] 68 | Pattern match(es) are non-exhaustive 69 | In an equation for ‘warning’: 70 | Patterns not matched: FIX_ME_BUT_FIRST IMPLEMENT_PARSING_FOR (C2 _) 71 | | 72 | 34 | warning LOOK_RIGHT_ABOVE = () 73 | | ^ 74 | ``` 75 | 76 | Making `warning` a method of a type class ensures that you won't get an unused function warning and it's also nice to pollute the global namespace with a bit fewer redundant names and instead share the same name for all functions triggering custom warnings. 77 | 78 | Overall, far from perfect, but better than nothing. 79 | 80 | **UPDATE** A number of people have [commented](https://www.reddit.com/r/haskell/comments/pi4hl3/a_custom_warning_hack) on this post suggesting alternative ideas: 81 | 82 | 1. instead of using a type class method, one can simply have a local function whose name starts with `_` and a comment above it requesting to update something. I think I still prefer for some kind of suggestion to appear in the warning itself, but YMMV 83 | 2. there exist packages solving this exact problem (all in their own way): [`surjective`](https://hackage.haskell.org/package/surjective), [`exhaustive`](https://hackage.haskell.org/package/exhaustive), [`sum-totality`](https://github.com/aaronallen8455/sum-totality) 84 | -------------------------------------------------------------------------------- /poly-type-of-saga/part1-try-unify/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE ExplicitForAll #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE PolyKinds #-} 8 | {-# LANGUAGE StandaloneKindSignatures #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | 13 | module Main where 14 | 15 | import Data.Kind 16 | import Data.Type.Equality 17 | import Data.Typeable 18 | import Test.QuickCheck 19 | 20 | infix 4 === 21 | type (===) :: forall a b. a -> b -> Bool 22 | type family x === y where 23 | x === x = 'True 24 | x === y = 'False 25 | 26 | type TryUnify :: forall a b. Bool -> a -> b -> Constraint 27 | class same ~ (x === y) => TryUnify same x y 28 | instance (x === y) ~ 'False => TryUnify 'False x y 29 | instance {-# INCOHERENT #-} (x ~~ y, same ~ 'True) => TryUnify same x y 30 | 31 | type (~?~) :: forall a b. a -> b -> Constraint 32 | type x ~?~ y = TryUnify (x === y) x y 33 | 34 | specifyAsInt :: Int -> Int 35 | specifyAsInt = id 36 | 37 | defaultToInt :: a ~?~ Int => a -> a 38 | defaultToInt = id 39 | 40 | defaultToDouble :: a ~?~ Double => a -> a 41 | defaultToDouble = id 42 | 43 | type DefaultAllTo :: forall a b. a -> b -> Constraint 44 | class DefaultAllTo d y 45 | instance (DefaultAllTo d f, DefaultAllTo d x) => DefaultAllTo d (f x) 46 | instance {-# INCOHERENT #-} (DefaultAllTo d b, d ~?~ y) => DefaultAllTo d (y :: b) 47 | 48 | defaultAllToInt :: DefaultAllTo Int a => a -> a 49 | defaultAllToInt = id 50 | 51 | defaultAllToList :: DefaultAllTo [] a => a -> a 52 | defaultAllToList = id 53 | 54 | defaultAllToTrue :: DefaultAllTo 'True a => a -> a 55 | defaultAllToTrue = id 56 | 57 | prop_reverseReverse :: Eq a => [a] -> Bool 58 | prop_reverseReverse xs = reverse (reverse xs) == xs 59 | 60 | -- >>> import Data.Proxy 61 | -- >>> import Data.Typeable 62 | -- >>> typeOf 'a' 63 | -- Char 64 | -- >>> typeOf (&&) 65 | -- Bool -> Bool -> Bool 66 | -- >>> typeOf id 67 | -- :176:2-10: error: 68 | -- • No instance for (Typeable a0) arising from a use of ‘typeOf’ 69 | -- • In the expression: typeOf id 70 | -- In an equation for ‘it’: it = typeOf id 71 | -- >>> :t 42 72 | -- 42 :: Num p => p 73 | -- >>> :t specifyAsInt 42 74 | -- specifyAsInt 42 :: Int 75 | -- >>> :t specifyAsInt True 76 | -- :1:14-17: error: 77 | -- • Couldn't match expected type ‘Int’ with actual type ‘Bool’ 78 | -- • In the first argument of ‘specifyAsInt’, namely ‘True’ 79 | -- In the expression: specifyAsInt True 80 | -- >>> :t defaultToInt 42 81 | -- defaultToInt 42 :: Int 82 | -- >>> :t defaultToInt True 83 | -- defaultToInt True :: Bool 84 | -- >>> :t defaultToInt [42] 85 | -- defaultToInt [42] :: Num a => [a] 86 | -- >>> :t defaultAllToInt reverse 87 | -- defaultAllToInt reverse :: [Int] -> [Int] 88 | -- >>> :t defaultAllToInt elem 89 | -- defaultAllToInt elem :: Foldable t => Int -> t Int -> Bool 90 | -- >>> :set -fprint-explicit-foralls 91 | -- >>> :t defaultAllToInt Proxy 92 | -- defaultAllToInt Proxy :: forall {t :: Int}. Proxy t 93 | -- >>> :unset -fprint-explicit-foralls 94 | -- >>> :t defaultAllToList fmap 95 | -- defaultAllToList fmap :: (a -> b) -> [a] -> [b] 96 | -- >>> :t defaultAllToTrue Proxy 97 | -- defaultAllToTrue Proxy :: Proxy 'True 98 | -- >>> :t defaultAllToList $ defaultAllToInt fmap 99 | -- defaultAllToList $ defaultAllToInt fmap 100 | -- :: (Int -> Int) -> [Int] -> [Int] 101 | -- >>> :t [defaultToInt 1, defaultToDouble 2] 102 | -- [defaultToInt 1, defaultToDouble 2] :: [Int] 103 | -- >>> :t [defaultToDouble 1, defaultToInt 2] 104 | -- [defaultToDouble 1, defaultToInt 2] :: [Double] 105 | 106 | quickCheckPoly :: (Testable prop, DefaultAllTo Int prop) => prop -> IO () 107 | quickCheckPoly = quickCheck 108 | 109 | main :: IO () 110 | main = quickCheckPoly prop_reverseReverse 111 | -------------------------------------------------------------------------------- /restore-interruptible/README.md: -------------------------------------------------------------------------------- 1 | # It's not a no-op to unmask an interruptible operation 2 | 3 | This post discusses one very subtle gotcha related to asynchronous exceptions and masking. The reader is assumed to be familiar with these concepts. If not, [Asynchronous Exception Handling in Haskell](https://www.fpcomplete.com/blog/2018/04/async-exception-handling-haskell) is a great tutorial. 4 | 5 | The gotcha is that this piece of code: 6 | 7 | ```haskell 8 | mask $ \restore -> do 9 | putMVar var x 10 | <...> 11 | ``` 12 | 13 | and this one: 14 | 15 | ```haskell 16 | mask $ \restore -> do 17 | restore $ putMVar var x 18 | <...> 19 | ``` 20 | 21 | are not equivalent, even though one could expect that `restore` unmasking async exceptions and essentially making a computation interruptible would have no effect on an already interruptible operation, which `putMVar` is. 22 | 23 | What's an interruprible operation? Quoting Asynchronous Exception Handling in Haskell: 24 | 25 | > To quote GHC's documentation: 26 | > 27 | > > Some operations are interruptible, which means that they can receive asynchronous exceptions even in the scope of a mask. Any function which may itself block is defined as interruptible... It is useful to think of mask not as a way to completely prevent asynchronous exceptions, but as a way to switch from asynchronous mode to polling mode. 28 | > 29 | > ```haskell 30 | > mask $ \restore -> do 31 | > a <- takeMVar m 32 | > restore (...) `catch` \e -> ... 33 | > ``` 34 | > 35 | > If `takeMVar` could not be interrupted, it would be possible for it to block on an `MVar` which has no chance of ever being filled, leading to a deadlock. Instead, GHC's runtime system adds the concept that, within a masked section, some actions can be considered to “poll” and check if there are async exceptions waiting. 36 | 37 | And there's one additional piece of information, quoting Parallel and Concurrent Programming (thanks to [Nicolas Frisby](https://github.com/nfrisby) for digging that out): 38 | 39 | > An interruptible operation may receive an asynchronous exception only if it actually blocks. 40 | 41 | With all of that in mind, let's dissect the behavior of the first snippet: 42 | 43 | ```haskell 44 | mask $ \restore -> do 45 | putMVar var x -- [1] 46 | <...> -- [2] 47 | ``` 48 | 49 | There are two scenarios: 50 | 51 | 1. `putMVar` does not block or temporarily blocks but unblocks before an async exception arrives (if any). The outcome: `var` gets filled with `x`, [1] succeeds, [2] executes 52 | 2. `putMVar` blocks (due to already being filled with, say, `y`) and an async exception arrives. The outcome: `putMVar` is cancelled (due to being an interruprible operation), `var` is left filled with `y`, [1] fails, [2] does not execute 53 | 54 | Now if we call `putMVar` within the scope of `restore`: 55 | 56 | 57 | ```haskell 58 | mask $ \restore -> do 59 | restore $ putMVar var x -- [1] 60 | <...> -- [2] 61 | ``` 62 | 63 | both of these scenarios can occur as well, however there's also a third one: 64 | 65 | 3. `putMVar` does not block and finishes (or temporarily blocks but unblocks) **right before an async exception arrives within the scope of `restore`**. That causes `putMVar` to succeed but the whole block enclosed in `restore` to fail. The outcome: `var` is filled with `x`, [1] fails, [2] does not execute 66 | 67 | This is a completely new scenario: previously [2] would execute iff `putMVar` succeeded, but now [2] can fail to execute even in case of `putMVar` succeeding, which can break an invariant in your code and cause a deadlock (which is how I discovered this subtlety when I was implementing tests for the [Prerun an action](https://github.com/effectfully-ou/haskell-challenges/tree/master/h5-prerun-action) challenge) 68 | 69 | So what happens is that `putMVar` does not fill the entire "exception-sensitive box" that `restore` creates within its scope. There's that tiny space between the internal `putMVar` and the enclosing `restore` where an async exception can be raised. So beware. 70 | 71 | **UPDATE**: see how [`dejafu`](http://hackage.haskell.org/package/dejafu) (a library for testing concurrent Haskell) can detect the new scenario and elaborate on it in [this comment](https://www.reddit.com/r/haskell/comments/nntfui/its_not_a_noop_to_unmask_an_interruptible/gzwtayp). 72 | -------------------------------------------------------------------------------- /has-lens-done-right/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MagicHash #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE PartialTypeSignatures #-} 8 | {-# LANGUAGE PolyKinds #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TupleSections #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# LANGUAGE TypeInType #-} 15 | 16 | module Main where 17 | 18 | import Control.Lens hiding (lens) 19 | import Data.Kind (Type) 20 | import GHC.Prim 21 | 22 | main :: IO () 23 | main = mempty 24 | 25 | -- Core 26 | -------------------- 27 | 28 | type family Get (x :: k) s 29 | 30 | class SameModulo (x :: k) s t where 31 | lensAt :: (SameModulo x t s, a ~ Get x s, b ~ Get x t) => Proxy# x -> Lens s t a b 32 | 33 | class (SameModulo x s t, SameModulo x t s, a ~ Get x s, b ~ Get x t) => HasLens x s t a b 34 | instance (SameModulo x s t, SameModulo x t s, a ~ Get x s, b ~ Get x t) => HasLens x s t a b 35 | 36 | type HasLens' x s a = HasLens x s s a a 37 | 38 | lens :: forall x s t a b. HasLens x s t a b => Lens s t a b 39 | lens = lensAt @x proxy# 40 | 41 | lens' :: forall x s a. HasLens' x s a => Lens' s a 42 | lens' = lens @x 43 | 44 | -- The 'User' example 45 | -------------------- 46 | 47 | data User = User 48 | { userEmail :: String 49 | , userName :: String 50 | } 51 | 52 | type instance Get "name" User = String 53 | instance t ~ User => SameModulo "name" User t where 54 | lensAt _ f (User email name) = User email <$> f name 55 | 56 | -- Found type wildcard ‘_’ standing for ‘([Char] -> String) -> User’ 57 | test0 :: _ 58 | test0 f = User "email" "name" & lens @"name" %~ f 59 | 60 | -- Found type wildcard ‘_’ standing for ‘User’ 61 | test1 :: _ -> User 62 | test1 user = user & lens @"name" .~ "new name" 63 | 64 | -- Tuple examples 65 | -------------------- 66 | 67 | type instance Get "_1" (a, b) = a 68 | instance t ~ (a', b) => SameModulo "_1" (a, b) t where 69 | lensAt _ = _1 70 | 71 | type instance Get "_1" (a, b, c) = a 72 | instance t ~ (a', b, c) => SameModulo "_1" (a, b, c) t where 73 | lensAt _ = _1 74 | 75 | -- Found type wildcard ‘_’ standing for ‘((a, Char), Bool)’ 76 | test2 :: forall a. (Enum a, Num a) => _ 77 | test2 = ((0 :: a, 'a'), True) & lens @"_1" . lens @"_1" %~ succ 78 | 79 | mono :: (HasLens' "_1" s sa, HasLens' "_1" sa a) => Lens' s a 80 | mono = lens' @"_1" . lens' @"_1" 81 | 82 | monoTuple :: Lens' ((a, b), c, d) a 83 | monoTuple = mono 84 | 85 | -- Inlined version also works. 86 | monoTupleInlined :: Lens' ((a, b), c, d) a 87 | monoTupleInlined = lens @"_1" . lens @"_1" 88 | 89 | poly 90 | :: (HasLens "_1" s t sa tb, HasLens "_1" sa tb a b) 91 | => Lens s t a b 92 | poly = lens @"_1" . lens @"_1" 93 | 94 | polyTuple :: Lens ((a, b), c, d) ((a', b), c, d) a a' 95 | polyTuple = poly 96 | 97 | -- Inlined version also works. 98 | polyTupleInlined :: Lens ((a, b), c, d) ((a', b), c, d) a a' 99 | polyTupleInlined = lens @"_1" . lens @"_1" 100 | 101 | -- Found type wildcard ‘_’ standing for ‘((Int, Bool), Char)’ 102 | polyTupleTest :: _ 103 | polyTupleTest = (("abc", True), 'd') & lens @"_1" . lens @"_1" %~ length 104 | 105 | -- The phantom arguments problem is solved (https://gitlab.haskell.org/ghc/ghc/wikis/records/overloaded-record-fields/design#type-changing-update-phantom-arguments): 106 | 107 | data Ph (a :: k) (bs :: [Bool]) = Ph { foo :: Int } 108 | 109 | type instance Get "foo" (Ph a b) = Int 110 | instance t ~ Ph (a' :: k') bs' => SameModulo "foo" (Ph a b) t where 111 | lensAt _ f (Ph i) = Ph <$> f i 112 | 113 | ph :: Lens (Ph (a :: k) bs) (Ph (a' :: k') bs') Int Int 114 | ph = lens @"foo" 115 | 116 | -- The type families problem is solved (https://gitlab.haskell.org/ghc/ghc/wikis/records/overloaded-record-fields/design#type-changing-update-type-families): 117 | -------------------- 118 | 119 | type family Goo (a :: k) 120 | data Tf (a :: k) = Tf { bar :: Goo a } 121 | 122 | type instance Get "bar" (Tf a) = Goo a 123 | instance t ~ Tf (a' :: k') => SameModulo "bar" (Tf (a :: k)) t where 124 | lensAt _ f (Tf x) = Tf <$> f x 125 | 126 | tf :: Lens (Tf (a :: k)) (Tf (a' :: k')) (Goo a) (Goo a') 127 | tf = lens @"bar" 128 | -------------------------------------------------------------------------------- /better-counterexample-minimization/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | {-# LANGUAGE DeriveFoldable #-} 5 | 6 | module Main (module Main) where 7 | 8 | import Test.QuickCheck 9 | 10 | data Tree a 11 | = Nil 12 | | Branch a (Tree a) (Tree a) 13 | deriving (Show) 14 | 15 | instance Arbitrary a => Arbitrary (Tree a) where 16 | arbitrary = undefined 17 | 18 | -- >>> import Test.QuickCheck 19 | -- >>> mapM_ print . shrink $ Branch True (Branch True Nil Nil) (Branch True Nil Nil) 20 | -- Nil 21 | -- Branch True Nil Nil 22 | -- Branch True Nil Nil 23 | -- Branch False (Branch True Nil Nil) (Branch True Nil Nil) 24 | -- Branch True Nil (Branch True Nil Nil) 25 | -- Branch True Nil (Branch True Nil Nil) 26 | -- Branch True Nil (Branch True Nil Nil) 27 | -- Branch True (Branch False Nil Nil) (Branch True Nil Nil) 28 | -- Branch True (Branch True Nil Nil) Nil 29 | -- Branch True (Branch True Nil Nil) Nil 30 | -- Branch True (Branch True Nil Nil) Nil 31 | -- Branch True (Branch True Nil Nil) (Branch False Nil Nil) 32 | -- shrink :: Tree a -> [Tree a] 33 | -- shrink Nil = [] 34 | -- shrink (Branch x l r) = 35 | -- -- shrink Branch to Nil 36 | -- [Nil] ++ 37 | -- -- shrink to subterms 38 | -- [l, r] ++ 39 | -- -- recursively shrink subterms 40 | -- [Branch x' l' r' | (x', l', r') <- shrink (x, l, r)] 41 | 42 | -- >>> import Test.QuickCheck 43 | -- >>> mapM_ print . shrink $ Branch True (Branch True Nil Nil) (Branch True Nil Nil) 44 | -- Nil 45 | -- Branch True Nil Nil 46 | -- Branch True Nil Nil 47 | -- Branch False (Branch True Nil Nil) (Branch True Nil Nil) 48 | -- Branch True Nil (Branch True Nil Nil) 49 | -- Branch True (Branch False Nil Nil) (Branch True Nil Nil) 50 | -- Branch True (Branch True Nil Nil) Nil 51 | -- Branch True (Branch True Nil Nil) (Branch False Nil Nil) 52 | -- shrink :: Tree a -> [Tree a] 53 | -- shrink Nil = [] 54 | -- shrink (Branch x l r) = 55 | -- -- shrink Branch to Nil 56 | -- [Nil] ++ 57 | -- -- shrink to subterms 58 | -- [t | t@Branch{} <- [l, r]] ++ 59 | -- -- recursively shrink subterms 60 | -- [Branch x' l' r' | (x', l', r') <- shrink (x, l, r)] 61 | 62 | -- >>> import Test.QuickCheck 63 | -- >>> mapM_ print . shrink $ Branch True (Branch True Nil Nil) (Branch True Nil Nil) 64 | -- Nil 65 | -- Branch True Nil Nil 66 | -- Branch True Nil Nil 67 | -- Branch True Nil (Branch True Nil Nil) 68 | -- Branch True (Branch True Nil Nil) Nil 69 | -- Branch False (Branch True Nil Nil) (Branch True Nil Nil) 70 | -- Branch True (Branch False Nil Nil) (Branch True Nil Nil) 71 | -- Branch True (Branch True Nil Nil) (Branch False Nil Nil) 72 | shrink :: Tree a -> [Tree a] 73 | shrink = uncurry (++) . go where 74 | go :: Tree a -> ([Tree a], [Tree a]) 75 | go Nil = ([], []) 76 | go (Branch x l r) = (tSp, tEl) where 77 | (lSp, lEl) = go l 78 | (rSp, rEl) = go r 79 | tSp = concat 80 | [ [Nil] 81 | , [t | t@Branch{} <- [l, r]] 82 | , [Branch x l' r | l' <- lSp] 83 | , [Branch x l r' | r' <- rSp] 84 | ] 85 | tEl = concat 86 | [ [Branch x' l r | x' <- shrink x] 87 | , [Branch x l' r | l' <- lEl] 88 | , [Branch x l r' | r' <- rEl] 89 | ] 90 | 91 | -- >>> import Test.QuickCheck 92 | -- >>> mapM_ print . shrink $ Branch (Branch True Nil Nil) Nil (Branch (Branch True Nil Nil) Nil Nil) 93 | -- Nil 94 | -- Branch (Branch True Nil Nil) Nil Nil 95 | -- Branch (Branch True Nil Nil) Nil Nil 96 | -- Branch Nil Nil (Branch (Branch True Nil Nil) Nil Nil) 97 | -- Branch (Branch False Nil Nil) Nil (Branch (Branch True Nil Nil) Nil Nil) 98 | -- Branch (Branch True Nil Nil) Nil (Branch Nil Nil Nil) 99 | -- Branch (Branch True Nil Nil) Nil (Branch (Branch False Nil Nil) Nil Nil) 100 | 101 | -- class PriorityShrink a where 102 | -- priorityShrink :: a -> ([a], [a]) 103 | 104 | -- shrinkViaPriorityShrink :: PriorityShrink a => a -> [a] 105 | -- shrinkViaPriorityShrink = uncurry (++) . priorityShrink 106 | 107 | -- instance PriorityShrink a => PriorityShrink (Tree a) where 108 | -- priorityShrink = undefined 109 | 110 | -- instance PriorityShrink a => Arbitrary (Tree a) where 111 | -- arbitrary = undefined 112 | -- shrink = shrinkViaPriorityShrink 113 | 114 | main :: IO () 115 | main = pure () 116 | -------------------------------------------------------------------------------- /generalizing-unliftio/src/UnliftPeel.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FunctionalDependencies #-} 7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | 13 | module UnliftPeel where 14 | 15 | import SomeAction 16 | 17 | import Control.Concurrent 18 | import Control.Monad.Except 19 | import Control.Monad.Trans.Reader 20 | import Debug.Trace 21 | 22 | class (Monad b, Monad m) => MonadUnliftPeel p b m | m b -> p, m p -> b where 23 | withUnliftPeel :: ((forall a. p a -> b a) -> b r) -> m r 24 | 25 | instance MonadUnliftPeel IO IO IO where 26 | withUnliftPeel k = k id 27 | 28 | instance MonadUnliftPeel p b m => MonadUnliftPeel (ReaderT e p) b (ReaderT e m) where 29 | withUnliftPeel k = ReaderT $ \r -> withUnliftPeel $ \unlift -> k $ unlift . flip runReaderT r 30 | 31 | instance {-# OVERLAPPABLE #-} MonadUnliftPeel p b m => MonadUnliftPeel p b (ExceptT e m) where 32 | withUnliftPeel k = 33 | trace "Dropping ExceptT" $ 34 | lift $ withUnliftPeel k 35 | 36 | instance {-# OVERLAPPING #-} 37 | MonadUnliftPeel p b m => MonadUnliftPeel (ExceptT e p) (ExceptT e b) (ExceptT e m) where 38 | withUnliftPeel k = 39 | trace "Keeping ExceptT" $ 40 | ExceptT $ withUnliftPeel $ \unlift -> runExceptT $ k $ mapExceptT unlift 41 | 42 | liftU :: MonadUnliftPeel m b m => b r -> m r 43 | liftU a = withUnliftPeel $ \_ -> a 44 | 45 | forkU :: MonadUnliftPeel p IO m => p () -> m ThreadId 46 | forkU a = withUnliftPeel $ \unlift -> forkIO $ unlift a 47 | 48 | throwErrorU :: (MonadUnliftPeel m b m, MonadError e b) => e -> m a 49 | throwErrorU = liftU . throwError 50 | 51 | catchErrorU :: (MonadUnliftPeel m b m, MonadError e b) => m a -> (e -> m a) -> m a 52 | catchErrorU a f = withUnliftPeel $ \unlift -> unlift a `catchError` (unlift . f) 53 | 54 | newtype App a = App 55 | { unApp :: ReaderT () IO a 56 | } deriving newtype (Functor, Applicative, Monad, MonadIO) 57 | deriving anyclass (SomeAction) 58 | 59 | instance MonadUnliftPeel App IO App where 60 | withUnliftPeel k = App $ withUnliftPeel $ \unlift -> k $ unlift . unApp 61 | 62 | runExceptTApp :: ExceptT () App a -> IO () 63 | runExceptTApp = void . flip runReaderT () . unApp . runExceptT 64 | 65 | -- >>> runExceptTApp testApp1 66 | -- Keeping ExceptT 67 | -- Keeping ExceptT 68 | -- performed some action 69 | -- () 70 | testApp1 :: ExceptT () App () 71 | testApp1 = throwErrorU () `catchErrorU` \() -> do 72 | _ <- lift $ forkU someAction 73 | printM () 74 | 75 | -- >>> runExceptTApp testApp2 76 | -- Keeping ExceptT 77 | -- Keeping ExceptT 78 | -- Dropping ExceptT 79 | -- performed some action 80 | -- () 81 | testApp2 :: ExceptT () App () 82 | testApp2 = throwErrorU () `catchErrorU` \() -> do 83 | _ <- forkU someAction 84 | printM () 85 | 86 | newtype AppT m a = AppT 87 | { unAppT :: ReaderT () m a 88 | } deriving newtype (Functor, Applicative, Monad, MonadIO) 89 | deriving anyclass (SomeAction) 90 | 91 | instance MonadUnliftPeel p b m => MonadUnliftPeel (AppT p) b (AppT m) where 92 | withUnliftPeel k = AppT $ withUnliftPeel $ \unlift -> k $ unlift . unAppT 93 | 94 | runAppTExcepT :: AppT (ExceptT () IO) a -> IO () 95 | runAppTExcepT = void . runExceptT . flip runReaderT () . unAppT 96 | 97 | -- >>> runAppTExcepT testAppT 98 | -- Keeping ExceptT 99 | -- Keeping ExceptT 100 | -- Dropping ExceptT 101 | -- performed some action 102 | -- () 103 | testAppT :: AppT (ExceptT () IO) () 104 | testAppT = throwErrorU () `catchErrorU` \() -> do 105 | _ <- forkU someAction 106 | printM () 107 | 108 | testAppG 109 | :: ( MonadUnliftPeel m b m, MonadError () b 110 | , MonadUnliftPeel p IO m 111 | , SomeAction p 112 | , MonadIO m 113 | ) 114 | => m () 115 | testAppG = throwErrorU () `catchErrorU` \() -> do -- MonadUnliftPeel m b m, MonadError () b 116 | _ <- 117 | forkU -- MonadUnliftPeel p IO m 118 | someAction -- SomeAction p 119 | printM () -- MonadIO m 120 | 121 | testApp2G :: ExceptT () App () 122 | testApp2G = testAppG 123 | 124 | testAppTG :: AppT (ExceptT () IO) () 125 | testAppTG = testAppG 126 | -------------------------------------------------------------------------------- /exhaustive-unordered-pattern-matching/README.md: -------------------------------------------------------------------------------- 1 | # And-patterns for exhaustive unordered pattern matching 2 | 3 | Consider some arbitrary data type `R` with two `Int` fields: 4 | 5 | ```haskell 6 | data R = R 7 | { a :: Int 8 | , b :: Int 9 | } 10 | ``` 11 | 12 | How would you implement, say, serialization for its values? You'd probably either do 13 | 14 | ```haskell 15 | serializeR (R x y) = do 16 | serializeA x 17 | serializeB y 18 | ``` 19 | 20 | or, with `NamedFieldPuns` enabled (note that the order of the arguments doesn't matter): 21 | 22 | 23 | ```haskell 24 | serializeR R{b, a} = do 25 | serializeA a 26 | serializeB b 27 | ``` 28 | 29 | Both of these approaches can be problematic: 30 | 31 | 1. for the former: what if somebody changes the ordering of the fields in `R` later on without realizing that `serializeR` needs to reflect the change? The type checker won't help in this case, since both the fields are of type `Int` 32 | 2. for the latter: what if somebody adds more fields to `R` later on without realizing that `serializeR` needs to reflect the change? The type checker won't help in this case, since the exhaustiveness of named-field-puns-matching isn't checked (there's a GHC [issue](https://gitlab.haskell.org/ghc/ghc/-/issues/15855) about that) 33 | 34 | One way to address this problem is by matching on the `R` value twice: once to ensure exhaustiveness and once to get the actual arguments without caring about their order: 35 | 36 | ```haskell 37 | {-# LANGUAGE NamedFieldPuns #-} 38 | {-# LANGUAGE PatternSynonyms #-} 39 | {-# LANGUAGE ViewPatterns #-} 40 | 41 | dup :: a -> (a, a) 42 | dup x = (x, x) 43 | 44 | infixr 0 :& 45 | pattern (:&) :: a -> a -> a 46 | pattern p1 :& p2 <- (dup -> (p1, p2)) 47 | {-# COMPLETE (:&) #-} 48 | 49 | serializeR :: R -> IO () 50 | serializeR (R _ _ :& R {b, a}) = do 51 | serializeA a 52 | serializeB b 53 | ``` 54 | 55 | **UPD** 56 | 57 | u/rampion [suggested](https://www.reddit.com/r/haskell/comments/1d9kexm/comment/lbatjee/) to use this implementation instead: 58 | 59 | ```haskell 60 | pattern (:&) :: a -> a -> a 61 | pattern a0:&a1 <- a0@a1 62 | {-# COMPLETE (:&) #-} 63 | ``` 64 | 65 | which magically works despite `@` not working directly without a pattern synonym. Go figure! 66 | 67 | With this approach changing the order of fields in `R` will not change the semantics of `serializeR` and adding new fields to `R` will cause pattern matching to fail with an error message like 68 | 69 | ``` 70 | • The constructor ‘R’ should have 3 arguments, but has been given 2 71 | • In the pattern: R _ _ 72 | In the pattern: R _ _ :& R {b, a} 73 | In an equation for ‘serializeR’: 74 | serializeR (R _ _ :& R {b, a}) 75 | = do serializeA a 76 | serializeB b 77 | ``` 78 | 79 | hence both the issues are solved. The trade-offs are 80 | 81 | 1. the trick makes the code look cryptic 82 | 2. when adding new fields to `R` and fixing `serializeR` there's a danger of increasing the number of `_`s while forgetting to add the new arguments as named fields puns (the `{b, a}` part) 83 | 3. the helpfulness of the trick reduces with each argument added, imagine counting underscores when there are dozens of them. Perhaps that could be automated via a standlone tool though, but that's a hassle. Maybe it's worth it for mission-critical code 84 | 85 | Also I wish `@` was an and-pattern instead of requiting its left operand to be a variable name, so that I could write this: 86 | 87 | ```haskell 88 | serializeR :: R -> IO () 89 | serializeR (R _ _)@(R {b, a}) = do 90 | serializeA a 91 | serializeB b 92 | ``` 93 | 94 | **UPD**: this post was [discussed](https://www.reddit.com/r/haskell/comments/1d9kexm/andpatterns_for_exhaustive_unordered_pattern) on Reddit. 95 | 96 | /u/brandonchinn178 [pointed](https://www.reddit.com/r/haskell/comments/1d9kexm/comment/l7ex96u/) out that [this](https://github.com/ghc-proposals/ghc-proposals/pull/436) proposal would address the issue on the language level. 97 | 98 | u/Faucelme [pointed](https://www.reddit.com/r/haskell/comments/1d9kexm/comment/l7i5csk/) out that making `serializeR` linear would require consuming all of its fields. 99 | 100 | u/enobayram [pointed](https://www.reddit.com/r/haskell/comments/1d9kexm/comment/l7is4v1/) out that the [`safe-wild-cards`](https://hackage.haskell.org/package/safe-wild-cards-1.0.0.2) package can be used instead of the trick described in this post. 101 | 102 | u/Innf107 [pointed](https://www.reddit.com/r/haskell/comments/1d9kexm/comment/l7fsz8c/) out that the coverage checked hates the trick and it indeed does if you add another constructor with fields to the `R` data type. 103 | 104 | Check out the full discussion for some more insightful comments. 105 | -------------------------------------------------------------------------------- /denotational-approximations/README.md: -------------------------------------------------------------------------------- 1 | # Denotational under- and over-approximations 2 | 3 | **EDIT** I changed some misleading wording in this post, sorry for being so unclear. 4 | 5 | I've recently made a [post about monadic lenses](https://github.com/effectfully/sketches/tree/master/extensible-monadic-lenses) and Edward Kmett reacted with 6 | 7 | > So here is an admittedly fairly brutal question that I pose to anybody who offers me "monadic lenses": 8 | 9 | > What, if any, are your laws? i.e. What tools can you offer users to reason about these things? 10 | 11 | so I want to talk about laws and reasoning in general. 12 | 13 | What are laws all about in Haskell? Equality. 14 | 15 | > The best way to start a fight in a room full of type theorists is to bring up the topic of equality. -- Conor McBride 16 | 17 | A law is usually of the form `x = y` for some notion and denotation of `=` (sometimes people write `=`, sometimes `~`, or `==`, or `~~`, or `===` (I prefer that one or unicode symbols like `≡` or `≈`), or `~~~`). The thing is that `=` is not defined rigorously anywhere. E.g. the `transformers` package defines these laws 18 | 19 | ```haskell 20 | lift . return = return 21 | lift (m >>= f) = lift m >>= (lift . f) 22 | ``` 23 | 24 | and the documentation for `pipes` states 25 | 26 | ```haskell 27 | -- The monad transformer laws are correct when viewed through the observe function: 28 | 29 | observe (lift (return r)) = observe (return r) 30 | observe (lift (m >>= f)) = observe (lift m >>= lift . f) 31 | ``` 32 | 33 | So the `pipes` package defines its own equality and `Pipe` is a quotient type actually. 34 | 35 | Everything related to bottoms and `seq` is completely ignored by that `=`. See [Hask is not a category](http://math.andrej.com/2016/08/06/hask-is-not-a-category/) and [State monads don't respect the monad laws in Haskell](https://mail.haskell.org/pipermail/haskell/2002-May/009622.html). 36 | 37 | Okay, so `=` is a rather vague beast. But besides being vague, its presentation also does some actual harm, because equalities usually hold denotationally (for some definition of "hold") and operational semantics (which is very important in the programming setting) is not even considered, which can lead to true bugs. Here is an example: by default `(*>)` is defined in terms of `(<*>)` like this: `a1 *> a2 = (id <$ a1) <*> a2` and `f <*> a` is very often strict and defined as "compute `f`, compute `a`, apply the result of the former computation to the result of the latter". Now if something fails to inline you get that `a1 *> a2` has this semantics: "compute `a1`, compute `a2`, discard the result of the former computation, return the result of the latter". "Sounds fine" you might think, but if `a2` is a recursive call, the computation won't be tail-recursive and you'll get a space leak. This is not some imaginary situation: I actually got a space leak, because `(*>)` wasn't specified for `Control.Monad.Trans.State.Strict` in the beginning of 2017. So I dumped Core and saw how a perfectly tail-recursive function compiles to something like 38 | 39 | ```haskell 40 | f 0 = return 1 41 | f x = f (x - 1) >>= return 42 | ``` 43 | 44 | which builds this grotesque thing in memory: `((f (x - 3) >>= return) >>= return) >>= return`. Yes, `m >>= return` and `m` differ operationally despite being denotationally the same thing. Even though GHC tries hard to be smart and optimize as much as possible, rewrite rules and inlining are not a panacea and optimizations can interfere with each other. That flaw can be fixed by presenting laws in a way like "`(<*>) === ap`, but prefer the former for efficiency reasons". 45 | 46 | The fact that a definition obeys some laws doesn't make it automatically well-behaved. `monad-control` has laws. Did it help? [No](http://blog.ezyang.com/2012/01/monadbasecontrol-is-unsound/). 47 | 48 | Speaking generally, **it is obviously good to have laws**, but it is not obviously bad not to have laws in case they weren't found for a particular abstraction (`Foldable`, `Alternative`, `MonadPlus` -- all these do not have clear laws and they're in `base`, laws for `Random` are not specified, `data-default` has 200k+ downloads, various pretty-printer libraries do not have any laws behind them and yet those libraries are extremely useful,`lens` has ad hoc classes like those in `Control.Lens.Cons`, etc). Speaking less generally, laws for pure lenses are very important, because 49 | 50 | > On the other hand, I'm not willing to give up on `PutPut` as it forms the backbone of reasoning about code written with lens and determining the canonical nature of the combinators we supply. -- Edward Kmett 51 | 52 | but I'm not yet convinced that supposed laws for monadic lenses are of the same importance, so I do not agree currently with the following sentiment: 53 | 54 | > the above situation [no laws for monadic lenses] ultimately killed any expression of a "monadic lens." 55 | -------------------------------------------------------------------------------- /has-lens-done-right/src/TF.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE MagicHash #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE PartialTypeSignatures #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | 14 | module TF where 15 | 16 | import Control.Lens hiding (lens) 17 | import qualified Control.Lens as Lens (lens) 18 | import Data.Proxy (Proxy (..)) 19 | import GHC.Exts (Proxy#, proxy#) 20 | import GHC.TypeLits (Symbol) 21 | 22 | -- Core 23 | -------------------- 24 | 25 | type family FldTy (r :: *) (n :: Symbol) :: * 26 | 27 | class t ~ FldTy r n => Has r (n :: Symbol) t where 28 | getField :: Proxy# n -> r -> t 29 | 30 | type family UpdTy (r :: *) (n :: Symbol) (a :: *) :: * 31 | 32 | class (Has r n (FldTy r n), r ~ UpdTy r n (FldTy r n)) => 33 | Upd (r :: *) (n :: Symbol) (t :: *) where 34 | setField :: Proxy# n -> r -> t -> UpdTy r n t 35 | 36 | lens 37 | :: forall n s t a b. (Upd s n b, t ~ UpdTy s n b, a ~ FldTy s n) 38 | => Lens s t a b 39 | lens = Lens.lens (getField pn) (setField pn) where 40 | pn :: Proxy# n 41 | pn = proxy# 42 | 43 | -- The 'User' example with half-good type inference 44 | -------------------- 45 | 46 | data User = User 47 | { userEmail :: String 48 | , userName :: String 49 | } 50 | 51 | type instance FldTy User "name" = String 52 | type instance UpdTy User "name" String = User 53 | 54 | instance t ~ String => Has User "name" t where 55 | getField _ (User _ name) = name 56 | 57 | instance t ~ String => Upd User "name" t where 58 | setField _ (User email _) name = User email name 59 | 60 | -- Found type wildcard ‘_’ standing for ‘([Char] -> [Char]) -> User’ 61 | test0 :: _ 62 | test0 f = User "john@gmail.com" "John" & lens @"name" %~ f 63 | 64 | -- Found type wildcard ‘_’ standing for ‘s0’ 65 | -- Where: ‘s0’ is an ambiguous type variable 66 | -- 67 | -- But also throws an error: 68 | -- 69 | -- Couldn't match type ‘UpdTy s0 "name" [Char]’ with ‘User’ arising from a use of ‘lens’ 70 | -- The type variable ‘s0’ is ambiguous 71 | -- 72 | -- test1 :: _ -> User 73 | -- test1 user = user & lens @"name" .~ "new name" 74 | 75 | -- The 'User' example with bad type inference 76 | -------------------- 77 | 78 | data NamelessGod = NamelessGod 79 | { namelessGodEmail :: String 80 | } 81 | 82 | type instance FldTy User "nameBad" = String 83 | type instance UpdTy User "nameBad" String = User 84 | type instance UpdTy User "nameBad" () = NamelessGod 85 | 86 | instance t ~ String => Has User "nameBad" t where 87 | getField _ (User _ name) = name 88 | 89 | instance Upd User "nameBad" String where 90 | setField _ (User email _) name = User email name 91 | 92 | instance Upd User "nameBad" () where 93 | setField _ (User email _) () = NamelessGod email 94 | 95 | -- Found type wildcard ‘_’ 96 | -- standing for ‘([Char] -> b0) -> UpdTy User "nameBad" b0’ 97 | -- Where: ‘b0’ is an ambiguous type variable 98 | -- 99 | -- But also throws an error: 100 | -- 101 | -- Ambiguous type variable ‘b0’ arising from a use of ‘lens’ 102 | -- prevents the constraint ‘(Upd User "nameBad" b0)’ from being solved. 103 | -- 104 | -- test0' :: _ 105 | -- test0' f = User "john@gmail.com" "John" & lens @"nameBad" %~ f 106 | 107 | -- Found type wildcard ‘_’ standing for ‘NamelessGod’ 108 | apotheosis :: _ 109 | apotheosis = User "john@gmail.com" "John" & lens @"nameBad" .~ () 110 | 111 | -- Tuple examples 112 | -------------------- 113 | 114 | type instance FldTy (a, b) "_1" = a 115 | type instance UpdTy (a, b) "_1" a' = (a', b) 116 | 117 | instance a ~ t => Has (a, b) "_1" t where 118 | getField _ (a, b) = a 119 | 120 | instance Upd (a, b) "_1" t where 121 | setField _ (_, y) x' = (x', y) 122 | 123 | -- Found type wildcard ‘_’ standing for ‘((a, Char), Bool)’ 124 | test2 :: forall a. (Enum a, Num a) => _ 125 | test2 = ((0 :: a, 'a'), True) & lens @"_1" . lens @"_1" %~ succ 126 | 127 | -- Poly-kinded update works 128 | -------------------- 129 | 130 | data UserK (x :: k) = UserK 131 | { nameK :: String 132 | , proxyK :: Proxy x 133 | } 134 | 135 | type instance FldTy (UserK (x :: k)) "proxyK" = Proxy x 136 | type instance UpdTy (UserK (x :: k)) "proxyK" (Proxy (x' :: k')) = UserK x' 137 | 138 | instance t ~ Proxy x => Has (UserK (x :: k)) "proxyK" t where 139 | getField _ (UserK _ proxy) = proxy 140 | 141 | instance t ~ Proxy (x' :: k') => Upd (UserK (x :: k)) "proxyK" t where 142 | setField _ (UserK name _) proxy = UserK name proxy 143 | 144 | -- Found type wildcard ‘_’ standing for ‘(Proxy "text" -> Proxy x') -> UserK x'’ 145 | test0K :: _ 146 | test0K f = UserK "john@gmail.com" (Proxy @"text") & lens @"proxyK" %~ f 147 | -------------------------------------------------------------------------------- /poly-traversable/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, DefaultSignatures, TypeFamilies #-} 3 | {-# LANGUAGE ConstraintKinds, ScopedTypeVariables, TypeOperators, TypeApplications #-} 4 | module Main where 5 | 6 | import GHC.Exts (Constraint) 7 | import Data.Word 8 | import Data.Proxy 9 | import Data.Monoid 10 | import Data.Foldable (toList) 11 | import Data.Functor.Identity 12 | import Data.Functor.Const 13 | import Data.Functor.Compose 14 | import Data.IntSet (IntSet) 15 | import qualified Data.IntSet as IntSet 16 | import Data.ByteString (ByteString) 17 | import qualified Data.ByteString as BS 18 | import Data.Text (Text) 19 | import qualified Data.Text as Text 20 | 21 | type family Element c 22 | type instance Element (f a) = a 23 | type instance Element IntSet = Int 24 | type instance Element ByteString = Word8 25 | type instance Element Text = Char 26 | 27 | data PolyShape (f :: * -> *) 28 | data MonoShape s 29 | 30 | type family ShapeOf s where 31 | ShapeOf (f _) = PolyShape f 32 | ShapeOf s = MonoShape s 33 | 34 | type family SpecifyShapeBy s t where 35 | SpecifyShapeBy (PolyShape f) t = f (Element t) 36 | SpecifyShapeBy (MonoShape s) _ = s 37 | 38 | type s `DeterminesShapeOf` t = t ~ SpecifyShapeBy (ShapeOf s) t 39 | type s `SameShape` t = (s `DeterminesShapeOf` t, t `DeterminesShapeOf` s) 40 | 41 | class ShapeOf s ~ ss => KnownShapeDispatch s ss where 42 | withKnownShape :: proxy s -> (forall f a. s ~ f a => c) -> (ShapeOf s ~ MonoShape s => c) -> c 43 | 44 | instance s ~ f a => KnownShapeDispatch s (PolyShape f) where 45 | withKnownShape _ poly _ = poly 46 | 47 | instance (ShapeOf s ~ MonoShape s, s ~ s') => KnownShapeDispatch s (MonoShape s') where 48 | withKnownShape _ _ mono = mono 49 | 50 | type KnownShape s = KnownShapeDispatch s (ShapeOf s) 51 | 52 | withReflexiveShapeOf :: forall s c. KnownShape s => s -> (s `SameShape` s => c) -> c 53 | withReflexiveShapeOf _ x = withKnownShape (Proxy :: Proxy s) x x 54 | 55 | withSymmetricShapes :: s `SameShape` t => Proxy (s, t) -> (t `SameShape` s => c) -> c 56 | withSymmetricShapes _ x = x 57 | 58 | withTransitiveShapes 59 | :: forall s t u c. (KnownShape s, s `SameShape` t, t `SameShape` u) 60 | => Proxy (s, t, u) -> (s `SameShape` u => c) -> c 61 | withTransitiveShapes _ x = withKnownShape (Proxy :: Proxy s) x x 62 | 63 | -- Just the same as `MonoFoldable`. 64 | class PolyFoldable s where 65 | pfoldMap :: Monoid m => (Element s -> m) -> s -> m 66 | default pfoldMap :: (Monoid m, s ~ f a, Foldable f) => (Element s -> m) -> s -> m 67 | pfoldMap = foldMap 68 | 69 | class s `SameShape` s => PolyFunctor s where 70 | pmap :: s `SameShape` t => (Element s -> Element t) -> s -> t 71 | default pmap :: (s ~ f a, t ~ f b, Functor f) => (Element s -> Element t) -> s -> t 72 | pmap = fmap 73 | 74 | class (PolyFunctor s, PolyFoldable s) => PolyTraversable s where 75 | ptraverse :: (s `SameShape` t, Applicative g) => (Element s -> g (Element t)) -> s -> g t 76 | default ptraverse :: (Applicative g, s ~ f a, t ~ f b, Traversable f) => (Element s -> g (Element t)) -> s -> g t 77 | ptraverse = traverse 78 | 79 | omap :: PolyFunctor s => (Element s -> Element s) -> s -> s 80 | omap = pmap 81 | 82 | pfoldMapDefault :: forall s m. (PolyTraversable s, Monoid m) => (Element s -> m) -> s -> m 83 | pfoldMapDefault f = getConst . ptraverse @s @s (Const . f) 84 | 85 | pfoldMapViaFoldr 86 | :: Monoid m 87 | => (forall b. (Element s -> b -> b) -> b -> s -> b) 88 | -> (Element s -> m) -> s -> m 89 | pfoldMapViaFoldr fr f = fr (mappend . f) mempty 90 | 91 | -- Could be `ptraverseViaIso` which receives an `Iso s t (f (Element s)) (f (Element t))`. 92 | ptraverseViaPackUnpack 93 | :: (Applicative g, Traversable f) 94 | => (f (Element t) -> t) 95 | -> (s -> f (Element s)) 96 | -> (Element s -> g (Element t)) -> s -> g t 97 | ptraverseViaPackUnpack pack unpack f = fmap pack . traverse f . unpack 98 | 99 | instance PolyFunctor [a] 100 | instance PolyFunctor (Maybe a) 101 | instance PolyFunctor (Const b a) 102 | 103 | instance PolyFoldable [a] 104 | instance PolyFoldable (Maybe a) 105 | instance PolyFoldable (Const b a) 106 | 107 | instance PolyTraversable [a] 108 | instance PolyTraversable (Maybe a) 109 | instance PolyTraversable (Const b a) 110 | 111 | instance PolyFunctor IntSet where 112 | pmap = IntSet.map 113 | instance PolyFunctor ByteString where 114 | pmap = BS.map 115 | instance PolyFunctor Text where 116 | pmap = Text.map 117 | 118 | instance PolyFoldable IntSet where 119 | pfoldMap = pfoldMapViaFoldr IntSet.foldr 120 | instance PolyFoldable ByteString where 121 | pfoldMap = pfoldMapViaFoldr BS.foldr 122 | instance PolyFoldable Text where 123 | pfoldMap = pfoldMapViaFoldr Text.foldr 124 | 125 | instance PolyTraversable IntSet where 126 | ptraverse = ptraverseViaPackUnpack IntSet.fromList IntSet.toList 127 | instance PolyTraversable ByteString where 128 | ptraverse = ptraverseViaPackUnpack BS.pack BS.unpack 129 | instance PolyTraversable Text where 130 | ptraverse = ptraverseViaPackUnpack Text.pack Text.unpack 131 | 132 | main :: IO () 133 | main = mempty 134 | -------------------------------------------------------------------------------- /custom-type-equality-errors/README.md: -------------------------------------------------------------------------------- 1 | # Custom type equality errors 2 | 3 | Consider the following snippet from the readme of the [`type-level-sets`](https://hackage.haskell.org/package/type-level-sets) library: 4 | 5 | ```haskell 6 | foo :: Map '["x" :-> Int, "z" :-> Bool, "w" :-> Int] 7 | foo = Ext (Var :: (Var "x")) 2 8 | $ Ext (Var :: (Var "z")) True 9 | $ Ext (Var :: (Var "w")) 5 -- [1] 10 | $ Empty 11 | ``` 12 | 13 | If we replace `5` with, say, `False` at [1] to introduce a type error, we'll see the following: 14 | 15 | ``` 16 | error: 17 | • Couldn't match type ‘Bool’ with ‘Int’ 18 | Expected type: Map '[ "x" ':-> Int, "z" ':-> Bool, "w" ':-> Int] 19 | Actual type: Map '[ "x" ':-> Int, "z" ':-> Bool, "w" ':-> Bool] 20 | • In the expression: 21 | Ext (Var :: (Var "x")) 2 22 | $ Ext (Var :: (Var "z")) True 23 | $ Ext (Var :: (Var "w")) False $ Empty 24 | <...> 25 | ``` 26 | 27 | By comparing the "Expected type" and "Actual type" lines we can figure out at which key the type mismatch has occurred, but such lines can get huge and it would be nice to be able to define custom type equality errors specifying important information directly (in our case, the key), so that the user does not need to dig it out themselves. Plus, in the above case we get to the error too late during type checking, which causes the whole expression to be printed in the error message. If the error was triggered in a more localized way, the error message would be less noisy and more to the point. 28 | 29 | There's a way to fix both of these problems. The trick is to define a separate type class mimicking type equality constraints but also having a custom equality check: 30 | 31 | ```haskell 32 | type CheckEqualKV :: forall k v. k -> k -> v -> v -> Constraint 33 | type family CheckEqualKV k1 k2 v1 v2 where 34 | CheckEqualKV k1 k1 v1 v1 = () -- Keys and values are equal, we're fine. 35 | CheckEqualKV k1 k2 v1 v2 = -- Something is not right, throw a type error. 36 | TypeError 37 | ( 'ShowType (k1 ':-> v1) ':<>: 38 | 'Text " is not equal to " ':<>: 39 | 'ShowType (k2 ':-> v2) 40 | ) 41 | 42 | type EqualKV :: forall k v. k -> k -> v -> v -> Constraint 43 | class (k1 ~ k2, v1 ~ v2) => EqualKV k1 k2 v1 v2 44 | instance (CheckEqualKV k1 k2 v1 v2, k1 ~ k2, v1 ~ v2) => EqualKV k1 k2 v1 v2 45 | ``` 46 | 47 | Here `EqualKV k1 k2 v1 v2` is almost the same thing as its superclass constraint `(k1 ~ k2, v1 ~ v2)`, except the former in addition to trying to unify `k1` with `k2` and `v1` with `v2` also invokes `CheckEqualKV k1 k2 v1 v2` at use site which triggers a custom type error whenever `k1` is not equal to `k2` or `v1` is not equal to `v2`. 48 | 49 | We only need to define an `EqualKV`-powered version of `Ext`: 50 | 51 | ```haskell 52 | -- cf.: Ext :: Var k -> v -> Map m -> Map ((k :-> v) ': m) 53 | ext :: EqualKV k1 k2 v1 v2 => Var k1 -> v1 -> Map m -> Map ((k2 :-> v2) ': m) 54 | ext = Ext 55 | ``` 56 | 57 | and we can check that using it in the definition of `foo` 58 | 59 | ```haskell 60 | foo :: Map '["x" :-> Int, "z" :-> Bool, "w" :-> Int] 61 | foo = ext (Var :: (Var "x")) 2 62 | $ ext (Var :: (Var "z")) True 63 | $ ext (Var :: (Var "w")) False 64 | $ Empty 65 | ``` 66 | 67 | indeed gives us a more comprehensible error message: 68 | 69 | ``` 70 | error: 71 | • "w" ':-> Bool is not equal to "w" ':-> Int 72 | • In the expression: ext (Var :: (Var "w")) False 73 | <...> 74 | ``` 75 | 76 | Note how the offending subexpression is well pinpointed. 77 | 78 | And we can extend `CheckEqualKV` with an additional clause when the two keys match and their values don't: 79 | 80 | ```haskell 81 | type family CheckEqualKV k1 k2 v1 v2 where 82 | CheckEqualKV k1 k1 v1 v1 = () 83 | CheckEqualKV k1 k1 v1 v2 = 84 | TypeError 85 | ( 'ShowType v1 ':<>: 86 | 'Text " is not equal to " ':<>: 87 | 'ShowType v2 ':<>: 88 | 'Text " at " ':<>: 89 | 'ShowType k1 90 | ) 91 | 92 | ``` 93 | 94 | to get an even more comprehensible error message: 95 | 96 | ``` 97 | error: 98 | • Bool is not equal to Int at "w" 99 | • In the expression: ext (Var :: (Var "w")) False 100 | <...> 101 | ``` 102 | 103 | Note that `EqualKV k1 k2 v1 v2` has `(k1 ~ k2, v1 ~ v2)` as its superclass constraint, which is no worse in terms of inference than substituting `k1` for `k2` and `v1` for `v2` directly in a type signature and so that `EqualKV` trick does not break inference. We can check that: the type of the following expression is still perfectly inferred: 104 | 105 | ```haskell 106 | -- >>> :t bar 107 | -- bar :: Map '[ "x" ':-> Int, "z" ':-> Bool, "w" ':-> Int] 108 | bar = ext (Var :: (Var "x")) (2 :: Int) 109 | $ ext (Var :: (Var "z")) True 110 | $ ext (Var :: (Var "w")) (5 :: Int) 111 | $ Empty 112 | ``` 113 | 114 | Full code is available at [`src/Main.hs`](./src/Main.hs). 115 | 116 | Thanks to [Emily](https://github.com/neongreen) for introducing me to the problem. 117 | 118 | See [this comment](https://www.reddit.com/r/haskell/comments/nomdit/custom_type_equality_errors/h037mf6) by [Adam Gundry](https://github.com/adamgundry) to understand how this trick is more or less reliable. 119 | -------------------------------------------------------------------------------- /validation-leak/README.md: -------------------------------------------------------------------------------- 1 | # validation-leak 2 | 3 | `Validation` and its applicative instance are defined something like this: 4 | 5 | ```haskell 6 | data Validation e a 7 | = Failure e 8 | | Success a 9 | 10 | instance Semigroup e => Applicative (Validation e) where 11 | pure = Success 12 | 13 | Failure e1 <*> Failure e2 = Failure (e1 <> e2) 14 | Failure e <*> Success _ = Failure e 15 | Success _ <*> Failure e = Failure e 16 | Success f <*> Success x = Success (f x) 17 | ``` 18 | 19 | Look at these two lines: 20 | 21 | ```haskell 22 | Failure e1 <*> Failure e2 = Failure (e1 <> e2) 23 | Failure e <*> Success _ = Failure e 24 | ``` 25 | 26 | If the first argument to `(<*>)` is a `Failure`, then we have a `Failure` regardless of what the second argument is. 27 | But nevertheless the second argument is forced before a final `Failure` is returned. This means that before 28 | any actual errors are returned, a whole computation must finish -- no lazy streaming of errors is possible. 29 | Which also implies that `Validation` can never be short-circuiting: even if you don't care about actual errors 30 | and just want to know whether a computation has finished successfully, you won't be able to stop early once an error has occured. 31 | In the same way if you only care about some particular error and have encountered it, it won't be possible to stop here -- 32 | all errors must be collected before the result of a `Validation e a` computation can be handled in any way. 33 | 34 | Here is a simple fix: 35 | 36 | ```haskell 37 | instance Monoid e => Applicative (Validation e) where 38 | pure = Success 39 | 40 | Failure e1 <*> b = Failure $ e1 `mappend` case b of 41 | Failure e2 -> e2 42 | Success _ -> mempty 43 | Success _ <*> Failure e = Failure e 44 | Success f <*> Success x = Success (f x) 45 | ``` 46 | 47 | If the first argument to `(<*>)` is a `Failure e1`, then return a `Failure` and prepend `e1` to the result which can be either `mempty` 48 | (if there are no more errors) or some `e2`. Note that this requires `e` to be a `Monoid` while previously it only had to be a `Semigroup`, 49 | so this instance is not strictly better than the leaking one. 50 | 51 | Similar considerations apply to `Control.Applicative.Lift`: 52 | 53 | ```haskell 54 | instance Applicative f => Applicative (Lift f) where 55 | pure = Pure 56 | 57 | Pure f <*> Pure x = Pure (f x) 58 | Pure f <*> Other y = Other (f <$> y) 59 | Other f <*> Pure x = Other (($ x) <$> f) 60 | Other f <*> Other y = Other (f <*> y) 61 | ``` 62 | 63 | Though, `($ x) <$> f` is better than `f <*> pure x`, so it's not immediately clear whether the `Applicative` instance for `Lift` should be changed. 64 | 65 | UPDATE: reddit user **xalyama** [suggested](https://www.reddit.com/r/haskell/comments/7hy4ml/validation_leaks/dqunqnf/) the following version 66 | 67 | ```haskell 68 | instance Semigroup e => Applicative (Validation e) where 69 | pure = Success 70 | 71 | Failure e1 <*> b = Failure $ case b of 72 | Failure e2 -> e1 <> e2 73 | Success _ -> e1 74 | Success _ <*> Failure e = Failure e 75 | Success f <*> Success x = Success (f x) 76 | ``` 77 | 78 | which [doesn't stream only the last occured failure](https://www.reddit.com/r/haskell/comments/7hy4ml/validation_leaks/dquoiow/), 79 | but streams all previous ones and also doesn't require `e` to be a `Monoid`. Hence this version is strictly better than what is commonly used at the time of writing. 80 | 81 | ## Testing 82 | 83 | A simple test 84 | 85 | ```haskell 86 | multifail :: (Except f [Int], Applicative f) => f () 87 | multifail = go 1000000 where 88 | go 0 = pure () 89 | go n = throw [n] *> go (n - 1) 90 | ``` 91 | 92 | reveals that `Leak.Validation` indeed leaks: 93 | 94 | ``` 95 | 500000500000 96 | 72,666,928 bytes allocated in the heap 97 | 125,238,824 bytes copied during GC 98 | 36,110,016 bytes maximum residency (7 sample(s)) 99 | 6,854,976 bytes maximum slop 100 | 87 MB total memory in use (0 MB lost due to fragmentation) 101 | 102 | Tot time (elapsed) Avg pause Max pause 103 | Gen 0 132 colls, 0 par 0.040s 0.048s 0.0004s 0.0009s 104 | Gen 1 7 colls, 0 par 0.044s 0.055s 0.0078s 0.0275s 105 | 106 | INIT time 0.000s ( 0.000s elapsed) 107 | MUT time 0.016s ( 0.017s elapsed) 108 | GC time 0.084s ( 0.103s elapsed) 109 | EXIT time 0.000s ( 0.004s elapsed) 110 | Total time 0.124s ( 0.124s elapsed) 111 | 112 | %GC time 67.7% (83.1% elapsed) 113 | 114 | Alloc rate 4,541,683,000 bytes per MUT second 115 | 116 | Productivity 32.3% of total user, 16.7% of total elapsed 117 | ``` 118 | 119 | and `Fine.Validation` indeed doesn't leak: 120 | 121 | ``` 122 | 500000500000 123 | 80,053,448 bytes allocated in the heap 124 | 270,200 bytes copied during GC 125 | 44,384 bytes maximum residency (2 sample(s)) 126 | 53,352 bytes maximum slop 127 | 1 MB total memory in use (0 MB lost due to fragmentation) 128 | 129 | Tot time (elapsed) Avg pause Max pause 130 | Gen 0 152 colls, 0 par 0.000s 0.000s 0.0000s 0.0002s 131 | Gen 1 2 colls, 0 par 0.000s 0.000s 0.0001s 0.0001s 132 | 133 | INIT time 0.000s ( 0.000s elapsed) 134 | MUT time 0.008s ( 0.009s elapsed) 135 | GC time 0.000s ( 0.001s elapsed) 136 | EXIT time 0.000s ( 0.000s elapsed) 137 | Total time 0.032s ( 0.010s elapsed) 138 | 139 | %GC time 0.0% (6.0% elapsed) 140 | 141 | Alloc rate 10,006,681,000 bytes per MUT second 142 | 143 | Productivity 100.0% of total user, 92.4% of total elapsed 144 | ``` 145 | -------------------------------------------------------------------------------- /has-lens-done-right/src/FunDep.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE KindSignatures #-} 7 | {-# LANGUAGE MagicHash #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE PartialTypeSignatures #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE RankNTypes #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE TypeApplications #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | 17 | module FunDep where 18 | 19 | import Control.Lens hiding (lens) 20 | import Data.Proxy 21 | import Data.Tagged 22 | import Data.Void 23 | import GHC.Exts (Proxy#, proxy#) 24 | 25 | -- Core 26 | -------------------- 27 | 28 | class HasLens (x :: k) s t a b | x s -> a, x t -> b, x s b -> t, x t a -> s where 29 | lensAt :: Proxy# x -> Lens s t a b 30 | 31 | lens :: forall x s t a b. HasLens x s t a b => Lens s t a b 32 | lens = lensAt @x proxy# 33 | 34 | -- The 'User' example with good type inference 35 | -------------------- 36 | 37 | data User = User 38 | { userEmail :: String 39 | , userName :: String 40 | } 41 | 42 | instance (a ~ String, b ~ String) => HasLens "name" User User a b where 43 | lensAt _ f (User email name) = User email <$> f name 44 | 45 | -- Found hole: _ :: [Char] -> [Char] 46 | -- 47 | -- test = User "john@gmail.com" "John" & lens @"name" %~ _ 48 | 49 | -- Found type wildcard ‘_’ standing for ‘([Char] -> [Char]) -> User’ 50 | test0 :: _ 51 | test0 f = User "john@gmail.com" "John" & lens @"name" %~ f 52 | 53 | -- Found type wildcard ‘_’ standing for ‘User’ 54 | test1 :: _ -> User 55 | test1 user = user & lens @"name" .~ "new name" 56 | 57 | -- The 'User' example with bad type inference 58 | -------------------- 59 | 60 | instance HasLens "nameBad" User User String String where 61 | lensAt _ f (User email name) = User email <$> f name 62 | 63 | -- Found hole: _ :: String -> b1 64 | -- Where: ‘b1’ is an ambiguous type variable 65 | -- 66 | -- test' = User "john@gmail.com" "John" & lens @"nameBad" %~ _ 67 | 68 | -- Found type wildcard ‘_’ standing for ‘(String -> b1) -> b0’ 69 | -- Where: ‘b1’ is an ambiguous type variable 70 | -- ‘b0’ is an ambiguous type variable 71 | -- 72 | -- Also throws an error: 73 | -- 74 | -- Ambiguous type variables ‘b0’, ‘b1’ arising from a use of ‘lens’ 75 | -- prevents the constraint ‘(HasLens "nameBad" User b0 String b1)’ from being solved. 76 | -- 77 | -- test0' :: _ 78 | -- test0' f = User "john@gmail.com" "John" & lens @"nameBad" %~ f 79 | 80 | -- Found type wildcard ‘_’ standing for ‘s0’ 81 | -- Where: ‘s0’ is an ambiguous type variable 82 | -- 83 | -- Also throws an error: 84 | -- 85 | -- Ambiguous type variables ‘s0’, ‘a0’ arising from a use of ‘lens’ 86 | -- prevents the constraint ‘(HasLens "nameBad" s0 User a0 [Char])’ from being solved. 87 | -- 88 | -- test1' :: _ -> User 89 | -- test1' user = user & lens @"nameBad" .~ "new name" 90 | 91 | data NamelessGod = NamelessGod 92 | { namelessGodEmail :: String 93 | } 94 | 95 | instance HasLens "nameBad" User NamelessGod String () where 96 | lensAt _ f (User email name) = NamelessGod email <$ f name 97 | 98 | apotheosis :: NamelessGod 99 | apotheosis = User "john@gmail.com" "John" & lens @"nameBad" .~ () 100 | 101 | instance HasLens "nameBad" User Void String Void where 102 | lensAt _ f (User _ name) = f name 103 | 104 | type Deathnote = String -> Void 105 | 106 | write :: Deathnote -> User -> Void 107 | write kill user = user & lens @"nameBad" %~ kill 108 | 109 | -- Tuple examples 110 | -------------------- 111 | 112 | instance HasLens "_1" (a, b) (a', b) a a' where 113 | lensAt _ = _1 114 | 115 | -- Found type wildcard ‘_’ standing for ‘((a, Char), Bool)’ 116 | test2 :: forall a. (Enum a, Num a) => _ 117 | test2 = ((0 :: a, 'a'), True) & lens @"_1" . lens @"_1" %~ succ 118 | 119 | -- Phantoms do not just work 120 | -------------------- 121 | 122 | data Ph (x :: k) (bs :: [Bool]) = Ph { foo :: Int } 123 | 124 | -- Illegal instance declaration for 125 | -- ‘HasLens "foo" (Ph x bs) (Ph x' bs') a b’ 126 | -- The liberal coverage condition fails in class ‘HasLens’ 127 | -- for functional dependency: ‘x s b -> t’ 128 | -- Reason: lhs types ‘"foo"’, ‘Ph x bs’, ‘b’ 129 | -- do not jointly determine rhs type ‘Ph x' bs'’ 130 | -- Un-determined variables: k', x', bs' 131 | -- 132 | -- instance (a ~ Int, b ~ Int) => HasLens "foo" (Ph (x :: k) bs) (Ph (x' :: k') bs') a b where 133 | -- lensAt _ f (Ph i) = Ph <$> f i 134 | 135 | -- Type families do not just work 136 | -------------------- 137 | 138 | type family Goo (x :: k) 139 | data Tf (x :: k) = Tf { bar :: Goo x } 140 | 141 | -- Illegal instance declaration for 142 | -- ‘HasLens "foo" (Tf x) (Tf x') a b’ 143 | -- The liberal coverage condition fails in class ‘HasLens’ 144 | -- for functional dependency: ‘x s b -> t’ 145 | -- Reason: lhs types ‘"bar"’, ‘Tf x’, ‘b’ 146 | -- do not jointly determine rhs type ‘Tf x'’ 147 | -- Un-determined variables: k', x' 148 | -- 149 | -- instance (a ~ Goo x, b ~ Goo x') => HasLens "bar" (Tf (x :: k)) (Tf (x' :: k')) a b where 150 | -- lensAt _ f (Tf x) = Tf <$> f x 151 | 152 | -- But with a bit of hacking phantoms do work 153 | -------------------- 154 | 155 | instance (a ~ Tagged ('(,) x bs) Int, b ~ Tagged ('(,) x' bs') Int) => 156 | HasLens "foo" (Ph (x :: k) bs) (Ph (x' :: k') bs') a b where 157 | lensAt _ f (Ph i) = Ph . unTagged <$> f (Tagged i) 158 | 159 | ph :: Lens (Ph (a :: k) bs) (Ph (a' :: k') bs') Int Int 160 | ph = lens @"foo" . coerced 161 | 162 | -- As well as type families 163 | -------------------- 164 | 165 | instance (a ~ Tagged x (Goo x), b ~ Tagged x' (Goo x')) => 166 | HasLens "bar" (Tf (x :: k)) (Tf (x' :: k')) a b where 167 | lensAt _ f (Tf x) = Tf . unTagged <$> f (Tagged x) 168 | 169 | tf :: Lens (Tf (a :: k)) (Tf (a' :: k')) (Goo a) (Goo a') 170 | tf = lens @"bar" . coerced 171 | -------------------------------------------------------------------------------- /a-law-breaking-hack/README.md: -------------------------------------------------------------------------------- 1 | # A law-breaking hack 2 | 3 | I saw a simple question, something like 4 | 5 | > How do you zip all elements in a list with `True` apart from the last one which you zip with `False`? 6 | 7 | and so I naturally asked myself "what would be the silliest way of doing this?". This post is an answer: I'll show how to abuse laziness and what kind of horrible consequences that has (spoiler: you can break a law by being lazy). 8 | 9 | Ok, so it would certainly be quite silly if we literally used `zip` over an input list and an arbitrary-length list of `True`s always ending in `False`. I.e. if we had such `lastIsFalse :: [Bool]` that 10 | 11 | ``` 12 | take (n + 1) lastIsFalse === replicate n True ++ [False] 13 | ``` 14 | 15 | holds for any `n`. Can we have such a definition in Haskell? Certainly not purely, but with ~undefined behavior~ `unsafePerformIO` anything is possible. Here we go: 16 | 17 | ```haskell 18 | lastIsFalse :: [Bool] 19 | lastIsFalse = unsafePerformIO $ do 20 | next <- newIORef False -- [1] 21 | let go = do 22 | b <- unsafeInterleaveIO $ readIORef next -- [2] 23 | bs <- unsafeInterleaveIO $ do -- [3] 24 | writeIORef next True -- [4] 25 | _ <- evaluate b -- [5] 26 | writeIORef next False -- [6] 27 | go -- [7] 28 | pure $ b : bs -- [8] 29 | go 30 | ``` 31 | 32 | Step by step: 33 | 34 | - [1]: the next element of a list is going to be stored in a variable called `next` 35 | - [2]: lazily retrieve the next element of a list. We don't know if it's `False` or `True` yet, 'cause `unsafeInterleaveIO` defers the `IO` action until its result is forced (we could've alternatively written `let b = unsafePerformIO $ readIORef next`, which is also lazy due to `let`-bindings being evaluated lazily) . At this point we only know that the value for `b` is going to be read from `next` when `b` is demanded 36 | - [3]: lazily retrieve the tail of the list and whenever it's forced by the caller, do all of these: 37 | * [4] & [5]: put `True` into `next` and immediately afterwards evaluate `b`. This ensures that `b` is `True` whenever the tail of the list is forced. I.e. if the caller asks for more elements, then `b` is not the last one that the caller needs and so it has to be `True` 38 | * [6] & [7]: put `False` back into `next`, so that if the tail of the tail is never forced, then the head of the tail will be read from `next` as `False`. Then recurse 39 | - [8]: attach the head to the tail 40 | 41 | We can check that this works as expected for a single-element list: 42 | 43 | ``` 44 | >>> init . take 1 $ zip [1..] lastIsFalse 45 | [] 46 | >>> last . take 1 $ zip [1..] lastIsFalse 47 | (1,False) 48 | ``` 49 | 50 | a two-element list: 51 | 52 | ``` 53 | >>> init . take 2 $ zip [1..] lastIsFalse 54 | [(1,True)] 55 | >>> last . take 2 $ zip [1..] lastIsFalse 56 | (2,False) 57 | ``` 58 | 59 | and, say, a five-element list: 60 | 61 | ``` 62 | >>> init . take 5 $ zip [1..] lastIsFalse 63 | [(1,True),(2,True),(3,True),(4,True)] 64 | >>> last . take 5 $ zip [1..] lastIsFalse 65 | (5,False) 66 | ``` 67 | 68 | "Okay, that seems to work, but why do you ask for the `init` and `last` of a list separately?" -- here's why: 69 | 70 | ``` 71 | >>> take 5 $ zip [1..] lastIsFalse 72 | [(1,False),(2,False),(3,False),(4,False),(5,False)] 73 | ``` 74 | 75 | Whoops, that's not right. Here's what's happening. Normally both `init` and `last` force the spine of a list and don't force any elements. But the spine of `lastIsFalse` is "entangled" with its elements, so in our case whenever the tail of a sublist of `lastIsFalse` is forced, the head of that sublist immediately evaluates to `True` and as such: 76 | 77 | - `init` forces all elements it returns and the remaining one never gets forced 78 | - `last` forces all elements it drops and the last one gets forced only when it's about to be printed 79 | 80 | But if we have neither `init` nor `last`, then the spine does not get forced before the elements do. Instead, the implicit `show` forces each element before forcing the rest of the list, i.e. before our carefully crafted entanglement has a chance to kick in and determine that the element at hand is not the last one. 81 | 82 | Hence we have to explicitly force the spine to get the right result. That can be done either via a strict right fold (never heard of that one, did you?): 83 | 84 | ```haskell 85 | foldr' :: (a -> r -> r) -> r -> [a] -> r 86 | foldr' f = foldr (($!) . f) 87 | ``` 88 | 89 | like this: 90 | 91 | ``` 92 | >>> foldr' (:) [] . take 5 $ zip [1..] lastIsFalse 93 | [(1,True),(2,True),(3,True),(4,True),(5,False)] 94 | ``` 95 | 96 | or, more interestingly, via `traverse pure`: 97 | 98 | ``` 99 | >>> traverse pure . take 5 $ zip [1..] lastIsFalse 100 | [(1,True),(2,True),(3,True),(4,True),(5,False)] 101 | ``` 102 | 103 | which forces the spine of the list just like `foldr'` due to `IO` being a strict `Applicative`, which causes `traverse` to process the entire list before anything can be returned (see [Constructing a list in a Monad](https://www.joachim-breitner.de/blog/620-Constructing_a_list_in_a_Monad) for a detailed analysis). 104 | 105 | ... but according to [the `Traversable` laws](https://en.wikibooks.org/wiki/Haskell/Traversable#The_Traversable_laws) `traverse pure` is supposed to be equal to `pure`. We can check that this is not the case: 106 | 107 | ``` 108 | >>> pure . take 5 $ zip [1..] lastIsFalse 109 | [(1,False),(2,False),(3,False),(4,False),(5,False)] 110 | ``` 111 | 112 | Moral of the story: if there's laziness exposed to the user, all laws are off. Which is of course something that people are well aware of: 113 | 114 | - [State monads don't respect the monad laws in Haskell](https://mail.haskell.org/pipermail/haskell/2002-May/009622.html) 115 | - [Hask is not a category](http://math.andrej.com/2016/08/06/hask-is-not-a-category/) 116 | 117 | `lastIsFalse` is particularly bad, because its value depends on how that value is consumed. Ah, and yeah, you can only step in the same river once: 118 | 119 | ``` 120 | >>> traverse pure . take 3 $ zip [1..] lastIsFalse 121 | [(1,True),(2,True),(3,False)] 122 | >>> traverse pure . take 5 $ zip [1..] lastIsFalse 123 | [(1,True),(2,True),(3,False),(4,True),(5,False)] 124 | ``` 125 | 126 | (note the `(3,False)` in the final line). I.e. if a part of `lastIsFalse` is forced at some point, it's going to stay the same if `lastIsFalse` is used again in the same program or GHCi session (all previous examples were separate GHCi sessions) due to`lastIsFalse` being a [CAF](https://stackoverflow.com/questions/8330756/what-are-super-combinators-and-constant-applicative-forms). 127 | 128 | Don't do any of that at home. 129 | --------------------------------------------------------------------------------