Planet Haskell

by geophf (noreply@blogger.com) at April 17, 2021 12:09 AM · product

f :: a -> a -> b
g :: b -> a -> a -> c
(\x y -> g (f x y) x y)
-- We will use this prefix for the remaining of the post.
-- VL stands for Van Laarhoven lenses.
import qualified Control.Lens as VL

-- Transform a pure function.
over :: VL.Lens s t a b -> (a -> b) -> (s -> t)

-- Transform an effectful function.
traverseOf :: VL.Traversal s t a b -> (a -> m b) -> (s -> m t)
overArrow :: VL.Lens s t a b -> Task a b -> Task s t
type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
first :: Task b c -> Task (b, d) (c, d)
second :: Task b c -> Task (d, b) (d, c)
_1 :: VL.Lens (b, d) (c, d) b c
_2 :: VL.Lens (d, b) (d, c) b c
type Optic p s t a b = p a b -> p s t
-- PL for Profunctor Lenses
import Control.Lens.Profunctor as PL
view _fst :: (a, b) -> a
class Profunctor p => Strong p where
  first' :: p a b -> p (a, c) (b, c)
  second' :: p a b -> p (c, a) (c, b)
type Lens s t a b = forall p. Strong p => p a b -> p s t
first' :: Lens' (a,c) (b,c) a b
second' :: Lens' (c,a) (c,b) a b
PL.fromLens :: VL.Lens s t a b -> Lens s t a b
PL.fromLens _1 :: Task a b -> Task (a,x,y) (b,x,y)
view _Left :: Either a b -> Maybe a
class Profunctor p => Choice p where
  left' :: p a b -> p (Either a c) (Either b c)
  right' :: p a b -> p (Either c a) (Either c b)
type Prism s t a b = forall p. Choice p => p a b -> p s t
left' :: Prism (Either a c) (Either b c) a b
right' :: Prism (Either c a) (Either c b) a b
PL.fromPrism :: VL.Prism s t a b -> Prism s t a b
PL.fromPrism _Just :: Action a b -> Action (Maybe a) (Maybe b)
mapMOf traverse readFile :: [FilePath] -> IO [String]
class (Choice p, Strong p) => Traversing p where
  traverse' :: Traversable f => p a b -> p (f a) (f b)
type Traversal s t a b = forall p. Traversing p => p a b -> p s t
traverse' :: Traversable f => Traversal (f a) (f b) a b
PL.fromTraversal :: VL.Traversal s t a b -> Traversal s t a b
PL.fromTraversal traverse :: Action a b -> Action [a] [b]
    unsafePerformIO $ do
        let x = f x
        writeIORef ref x
        return x
use nix --keep XDG_DATA_DIRS

withDefault def x =
    case x of
        | #Ok v -> v
        | #Err _ -> def
    end
withDefault def x =
    case x of
        | #Ok 0 -> def
        | #Ok v -> v
        | _ -> def
    end
Equality (TypeVar tv) (TypePolyVariantUB tv [(<label>, <payload-type>)])
Equality (TypeVar tv) (TypePolyVariantLB [] tv2)
Equality (TypePolyVariantUB tv <merged-fields>) (TypeVar tv)
withDefault def x =
    case x of
        | #Some v -> v
        | #Nil _ -> def
    end

one = withDefault 0 (#Some 1)
    +---- targ3 -> t4 -> t5
    |
    |        +---- targ3
    |        |
    |        |  +----- t4
    |        |  |
withDefault def x =
         +------------ t4
         |
    case x of        +---- t7
                     |
        | #Some v -> v

        | #Nil _ -> def
                     |
                     |
                     +---- targ3
    end

-- Constraints:

[ Equality t4 t6
, Equality t5 t7
, Equality t5 targ3
, Equality t6 [< Nil : t9 | (t6)]
, Equality t6 [< Some : t7 | (t6)]
, Equality t7 t8
, Equality t9 t10
, Equality tfun2 (targ3 -> t4 -> t5)
, Equality top0 (targ3 -> t4 -> t5)
]
 +-- t16
 |         +--- top0_i11
 |         |
 |         |      +---- Int
 |         |      |
 |         |      |    +---- t14 -> [> Some : t14 | (t13)]
 |         |      |    |
 |         |      |    |   +--- Int
 |         |      |    |   |
one = withDefault 0 (#Some 1)
                     -------
                        |
                        +--- t15

-- Constraints:

[ Equality t12 (t15 -> t16)
, Equality top0_i11 (Int -> t12)
, Equality top1 t16
, Equality (t14 -> [> Some : t14 | (t13)]) (Int -> t15)
, InstanceOf top0_i11 top0
]
[ Equality t4 t6
, Equality t5 t7
, Equality t5 targ3
, Equality t6 [< Nil : t9 | (t6)]
, Equality t6 [< Some : t7 | (t6)]
, Equality t7 t8
, Equality t9 t10
, Equality tfun2 (targ3 -> t4 -> t5)
, Equality top0 (targ3 -> t4 -> t5)
]

-- Constraints:
    [ Equality t4 t6
    , Equality t5 t7
    , Equality t5 targ3
    , Equality t6 [< Nil : t9 | (t6)]
    , Equality t6 [< Some : t7 | (t6)]
    , Equality t7 t8
    , Equality t9 t10
    , Equality tfun2 (targ3 -> t4 -> t5)
    , Equality top0 (targ3 -> t4 -> t5)
    ]
-- Substitution:
    []

1. Equality t4 t6
   -- => t4 := t6

-- Constraints:
    [ Equality t5 t7
    , Equality t5 targ3
    , Equality t6 [< Nil : t9 | (t6)]
    , Equality t6 [< Some : t7 | (t6)]
    , Equality t7 t8
    , Equality t9 t10
    , Equality tfun2 (targ3 -> t6 -> t5)
    , Equality top0 (targ3 -> t6 -> t5)
    ]
-- Substitution:
    [ t4 := t6
    ]

2. Equality t5 t7
   -- => t5 := t7

-- Constraints:
    [ Equality t7 t7
    , Equality t7 targ3
    , Equality t6 [< Nil : t9 | (t6)]
    , Equality t6 [< Some : t7 | (t6)]
    , Equality t7 t8
    , Equality t9 t10
    , Equality tfun2 (targ3 -> t6 -> t7)
    , Equality top0 (targ3 -> t6 -> t7)
    ]
-- Substitution:
    [ t4 := t6
    , t5 := t7
    ]

3. Equality t7 t7
   -- => Nothing to do

-- Constraints:
    [ Equality t7 targ3
    , Equality t6 [< Nil : t9 | (t6)]
    , Equality t6 [< Some : t7 | (t6)]
    , Equality t7 t8
    , Equality t9 t10
    , Equality tfun2 (targ3 -> t6 -> t7)
    , Equality top0 (targ3 -> t6 -> t7)
    ]
-- Substitution:
    unchanged

4. Equality t7 targ3
   -- => t7 := targ3

-- Constraints:
    [ Equality t6 [< Nil : t9 | (t6)]
    , Equality t6 [< Some : targ3 | (t6)]
    , Equality targ3 t8
    , Equality t9 t10
    , Equality tfun2 (targ3 -> t6 -> targ3)
    , Equality top0 (targ3 -> t6 -> targ3)
    ]
-- Substitution:
    [ t4 := t6
    , t5 := targ3
    , t7 := targ3
    ]

5. Equality t6 [< Nil : t9 | (t6)]
   -- => t6 := [< Nil : t9 | (t6)] -- note that we don't do occurs check here

-- Constraints:
    [ Equality [< Nil : t9 | (t6)] [< Nil : t9 | (t6)]
    , Equality [< Nil : t9 | (t6)] [< Nil : t9 | Some : targ3 | (t6)]
    , Equality targ3 t8
    , Equality t9 t10
    , Equality tfun2 (targ3 -> [< Nil : t9 | (t6)] -> targ3)
    , Equality top0 (targ3 -> [< Nil : t9 | (t6)] -> targ3)
    ]
-- Substitution:
    [ t4 := [< Nil : t9 | (t6)]
    , t5 := targ3
    , t7 := targ3
    , t6 := [< Nil : t9 | (t6)]
    ]

6. Equality [< Nil : t9 | (t6)] [< Nil : t9 | (t6)]
   -- => The two sides are the same, nothing to do.

-- Constraints:
    [ Equality [< Nil : t9 | (t6)] [< Nil : t9 | Some : targ3 | (t6)]
    , Equality targ3 t8
    , Equality t9 t10
    , Equality tfun2 (targ3 -> [< Nil : t9 | (t6)] -> targ3)
    , Equality top0 (targ3 -> [< Nil : t9 | (t6)] -> targ3)
    ]
-- Substitution:
    unchanged

7. Equality [< Nil : t9 | (t6)] [< Nil : t9 | Some : targ3 | (t6)]
   -- => [ Equality t6 [< Nil : t9 | Some : targ3 | (t6)], Equality t9 t9 ]

-- Constraints:
    [ Equality t6 [< Nil : t9 | Some : targ3 | (t6)]
    , Equality t9 t9
    [ Equality [< Nil : t9 | (t6)] [< Nil : t9 | Some : targ3 | (t6)]
    , Equality targ3 t8
    , Equality t9 t10
    , Equality tfun2 (targ3 -> [< Nil : t9 | (t6)] -> targ3)
    , Equality top0 (targ3 -> [< Nil : t9 | (t6)] -> targ3)
    ]
-- Substitution:
    unchanged

8. Equality [< Nil : t9 | (t6)] [< Nil : t9 | Some : targ3 | (t6)]
   -- => t6 := [< Nil : t9 | Some : targ3 | (t6)]

-- Constraints:
    [ Equality t9 t9
    , Equality targ3 t8
    , Equality t9 t10
    , Equality tfun2 (targ3 -> [< Nil : t9 | Some : targ3 | (t6)] -> targ3)
    , Equality top0 (targ3 -> [< Nil : t9 | Some : targ3 | (t6)] -> targ3)
    ]
-- Substitution:
    [ t4 := [< Nil : t9 | Some : targ3 | (t6)]
    , t5 := targ3
    , t7 := targ3
    , t6 := [< Nil : t9 | Some : targ3 | (t6)]
    ]

9. Equality t9 t9
   -- => Nothing to do

-- Constraints:
    [ Equality targ3 t8
    , Equality t9 t10
    , Equality tfun2 (targ3 -> [< Nil : t9 | Some : targ3 | (t6)] -> targ3)
    , Equality top0 (targ3 -> [< Nil : t9 | Some : targ3 | (t6)] -> targ3)
    ]
-- Substitution:
    [ t4 := [< Nil : t9 | Some : targ3 | (t6)]
    , t5 := targ3
    , t7 := targ3
    , t6 := [< Nil : t9 | Some : targ3 | (t6)]
    ]

10. Equality targ3 t8
    -- => targ3 := t8

-- Constraints:
    [ Equality t9 t10
    , Equality tfun2 (t8 -> [< Nil : t9 | Some : t8 | (t6)] -> t8)
    , Equality top0 (t8 -> [< Nil : t9 | Some : t8 | (t6)] -> t8)
    ]
-- Substitution:
    [ t4 := [< Nil : t9 | Some : t8 | (t6)]
    , t5 := t8
    , t7 := t8
    , t6 := [< Nil : t9 | Some : t8 | (t6)]
    , targ3 := t8
    ]

11. Equality t9 t10
    -- => t9 := t10

-- Constraints:
    [ Equality tfun2 (t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8)
    , Equality top0 (t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8)
    ]
-- Substitution:
    [ t4 := [< Nil : t10 | Some : t8 | (t6)]
    , t5 := t8
    , t7 := t8
    , t6 := [< Nil : t10 | Some : t8 | (t6)]
    , targ3 := t8
    , t9 := t10
    ]

11. Equality tfun2 (t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8)
    -- => tfun2 := (t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8)

-- Constraints:
    [ Equality top0 (t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8)
    ]
-- Substitution:
    [ t4 := [< Nil : t10 | Some : t8 | (t6)]
    , t5 := t8
    , t7 := t8
    , t6 := [< Nil : t10 | Some : t8 | (t6)]
    , targ3 := t8
    , t9 := t10
    , tfun2 := t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8
    ]

12. Equality top0 (t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8)
    -- => top0 := t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8

-- Constraints: []
-- Substitution:
    [ t4 := [< Nil : t10 | Some : t8 | (t6)]
    , t5 := t8
    , t7 := t8
    , t6 := [< Nil : t10 | Some : t8 | (t6)]
    , targ3 := t8
    , t9 := t10
    , tfun2 := t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8
    , top0 := t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8
    ]
[ Equality t12 (t15 -> t16)
, Equality top0_i11 (Int -> t12)
, Equality top1 t16
, Equality (t14 -> [> Some : t14 | (t13)]) (Int -> t15)
, InstanceOf top0_i11 top0
]
[ Equality t12 (t15 -> t16)
, Equality top0_i11 (Int -> t12)
, Equality top1 t16
, Equality (t14 -> [> Some : t14 | (t13)]) (Int -> t15)
, InstanceOf top0_i11 (t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8)
]
-- Constraints:
    [ Equality t12 (t15 -> t16)
    , Equality top0_i11 (Int -> t12)
    , Equality top1 t16
    , Equality (t14 -> [> Some : t14 | (t13)]) (Int -> t15)
    , InstanceOf top0_i11 (t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8)
    ]
-- Substitution:
    [ t4 := [< Nil : t10 | Some : t8 | (t6)]
    , t5 := t8
    , t7 := t8
    , t6 := [< Nil : t10 | Some : t8 | (t6)]
    , targ3 := t8
    , t9 := t10
    , tfun2 := t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8
    , top0 := t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8
    ]

1. Equality t12 (t15 -> t16)
    -- => t12 := t15 -> t16

-- Constraints:
    [ Equality top0_i11 (Int -> t15 -> t16)
    , Equality top1 t16
    , Equality (t14 -> [> Some : t14 | (t13)]) (Int -> t15)
    , InstanceOf top0_i11 (t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8)
    ]
-- Substitution:
    [ t4 := [< Nil : t10 | Some : t8 | (t6)]
    , t5 := t8
    , t7 := t8
    , t6 := [< Nil : t10 | Some : t8 | (t6)]
    , targ3 := t8
    , t9 := t10
    , tfun2 := t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8
    , top0 := t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8
    , t12 := t15 -> t16
    ]

2. Equality top0_i11 (Int -> t15 -> t16)
    -- => top0_i11 := Int -> t15 -> t16

-- Constraints:
    [ Equality top1 t16
    , Equality (t14 -> [> Some : t14 | (t13)]) (Int -> t15)
    , InstanceOf (Int -> t15 -> t16) (t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8)
    ]
-- Substitution:
    [ t4 := [< Nil : t10 | Some : t8 | (t6)]
    , t5 := t8
    , t7 := t8
    , t6 := [< Nil : t10 | Some : t8 | (t6)]
    , targ3 := t8
    , t9 := t10
    , tfun2 := t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8
    , top0 := t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8
    , t12 := t15 -> t16
    , top0_i11 := Int -> t15 -> t16
    ]

3. Equality top1 t16
    -- => top1 := t16

-- Constraints:
    [ Equality (t14 -> [> Some : t14 | (t13)]) (Int -> t15)
    , InstanceOf (Int -> t15 -> t16) (t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8)
    ]
-- Substitution:
    [ t4 := [< Nil : t10 | Some : t8 | (t6)]
    , t5 := t8
    , t7 := t8
    , t6 := [< Nil : t10 | Some : t8 | (t6)]
    , targ3 := t8
    , t9 := t10
    , tfun2 := t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8
    , top0 := t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8
    , t12 := t15 -> t16
    , top0_i11 := Int -> t15 -> t16
    , top1 := t16
    ]

4. Equality (t14 -> [> Some : t14 | (t13)]) (Int -> t15)
    -- => [ Equality t14 Int, Equality [> Some : t14 | (t13)] t15 ]

-- Constraints:
    [ Equality t14 Int
    , Equality [> Some : t14 | (t13)] t15
    , Equality (t14 -> [> Some : t14 | (t13)]) (Int -> t15)
    , InstanceOf (Int -> t15 -> t16) (t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8)
    ]
-- Substitution:
    unchanged

5. Equality t14 Int
    -- => t14 := Int

-- Constraints:
    [ Equality [> Some : Int | (t13)] t15
    , Equality (Int -> [> Some : Int | (t13)]) (Int -> t15)
    , InstanceOf (Int -> t15 -> t16) (t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8)
    ]
-- Substitution:
    [ t4 := [< Nil : t10 | Some : t8 | (t6)]
    , t5 := t8
    , t7 := t8
    , t6 := [< Nil : t10 | Some : t8 | (t6)]
    , targ3 := t8
    , t9 := t10
    , tfun2 := t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8
    , top0 := t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8
    , t12 := t15 -> t16
    , top0_i11 := Int -> t15 -> t16
    , top1 := t16
    , t14 := Int
    ]

6. Equality [> Some : Int | (t13)] t15
    -- => t15 := [> Some : Int | (t13)]

-- Constraints:
    [ Equality (Int -> [> Some : Int | (t13)]) (Int -> [> Some : Int | (t13)])
    , InstanceOf (Int -> [> Some : Int | (t13)] -> t16) (t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8)
    ]
-- Substitution:
    [ t4 := [< Nil : t10 | Some : t8 | (t6)]
    , t5 := t8
    , t7 := t8
    , t6 := [< Nil : t10 | Some : t8 | (t6)]
    , targ3 := t8
    , t9 := t10
    , tfun2 := t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8
    , top0 := t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8
    , t12 := [> Some : Int | (t13)] -> t16
    , top0_i11 := Int -> [> Some : Int | (t13)] -> t16
    , top1 := t16
    , t14 := Int
    , t15 := [> Some : Int | (t13)]
    ]

7. Equality (Int -> [> Some : Int | (t13)]) (Int -> [> Some : Int | (t13)])
    -- => [ Equality Int Int, Equality [> Some : Int | (t13)] [> Some : Int | (t13)] ]

-- Constraints:
    [ Equality Int Int
    , Equality [> Some : Int | (t13)] [> Some : Int | (t13)]
    , InstanceOf (Int -> [> Some : Int | (t13)] -> t16) (t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8)
    ]
-- Substitution:
    unchanged

8. The two sides are equals so we skip them
9. The two sides are equals so we skip them

10. InstanceOf (Int -> [> Some : Int | (t13)] -> t16) (t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8)
    -- => [ Equality (Int -> [> Some : Int | (t13)] -> t16) (t17 -> [< Nil : t18 | Some : t17 | (t19)] -> t17) ] -- (instantiation)

-- Constraints:
    [ Equality (Int -> [> Some : Int | (t13)] -> t16) (t17 -> [< Nil : t18 | Some : t17 | (t19)] -> t17)
    ]
-- Substitution:
    unchanged

11. Equality (Int -> [> Some : Int | (t13)] -> t16) (t17 -> [< Nil : t18 | Some : t17 | (t19)] -> t17)
    -- => [ Equality Int t17, Equality [> Some : Int | (t13)] [< Nil : t18 | Some : t17 | (t19)], Equality t16 t17 ]

-- Constraints:
    [ Equality Int t17
    , Equality [> Some : Int | (t13)] [< Nil : t18 | Some : t17 | (t19)]
    , Equality t16 t17 
    ]
-- Substitution:
    unchanged

11. Equality Int t17
    -- => t17 := Int

-- Constraints:
    [ Equality [> Some : Int | (t13)] [< Nil : t18 | Some : Int | (t19)]
    , Equality t16 Int 
    ]
-- Substitution:
    [ t4 := [< Nil : t10 | Some : t8 | (t6)]
    , t5 := t8
    , t7 := t8
    , t6 := [< Nil : t10 | Some : t8 | (t6)]
    , targ3 := t8
    , t9 := t10
    , tfun2 := t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8
    , top0 := t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8
    , t12 := [> Some : Int | (t13)] -> t16
    , top0_i11 := Int -> [> Some : Int | (t13)] -> t16
    , top1 := t16
    , t14 := Int
    , t15 := [> Some : Int | (t13)]
    , t17 := Int
    ]

12. Equality [> Some : Int | (t13)] [< Nil : t18 | Some : Int | (t19)]
    -- => Equality [> Some : Int | (t13)] [ Nil : t18 | Some : Int ] -- LB ~ UB are solved like LB and normal variant

-- Constraints:
    [ Equality [> Some : Int | (t13)] [ Nil : t18 | Some : Int ]
    , Equality t16 Int 
    ]
-- Substitution:
    unchanged

13. Equality [> Some : Int | (t13)] [ Nil : t18 | Some : Int ]
    -- => [ Equality Int Int, Equality [ Nil : t18 ] t13 ]

-- Constraints:
    [ Equality Int Int
    , Equality [ Nil : t18 ] t13
    , Equality t16 Int 
    ]
-- Substitution:
    unchanged

14. Two sides are equal, skip

15. Equality [ Nil : t18 ] t13
    -- => t13 := [ Nil : t18 ]

-- Constraints:
    [ Equality t16 Int 
    ]
-- Substitution:
    [ t4 := [< Nil : t10 | Some : t8 | (t6)]
    , t5 := t8
    , t7 := t8
    , t6 := [< Nil : t10 | Some : t8 | (t6)]
    , targ3 := t8
    , t9 := t10
    , tfun2 := t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8
    , top0 := t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8
    , t12 := [ Nil : t18 | Some : Int ] -> t16             -- * substitution of LB with normal variant
    , top0_i11 := Int -> [ Nil : t18 | Some : Int ] -> t16 -- * here too
    , top1 := t16
    , t14 := Int
    , t15 := [ Nil : t18 | Some : Int ]                    -- * and here
    , t17 := Int
    ]

16. Equality t16 Int
    -- => t16 := Int

-- Constraints: []
-- Substitution:
    [ t4 := [< Nil : t10 | Some : t8 | (t6)]
    , t5 := t8
    , t7 := t8
    , t6 := [< Nil : t10 | Some : t8 | (t6)]
    , targ3 := t8
    , t9 := t10
    , tfun2 := t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8
    , top0 := t8 -> [< Nil : t10 | Some : t8 | (t6)] -> t8
    , t12 := [ Nil : t18 | Some : Int ] -> Int             -- * substitution of LB with normal variant
    , top0_i11 := Int -> [ Nil : t18 | Some : Int ] -> Int -- * here too
    , top1 := Int
    , t14 := Int
    , t15 := [ Nil : t18 | Some : Int ]                    -- * and here
    , t17 := Int
    , t16 := Int
    ]
    +---- t8 -> [< Nil : t10 | Some : t8 ] -> t8
    |
    |        +---- t8
    |        |
    |        |  +----- [< Nil : t10 | Some : t8 ]
    |        |  |
withDefault def x =
         +------------ [< Nil : t10 | Some : t8 ]
         |
    case x of        +---- t8
                     |
        | #Some v -> v

        | #Nil _ -> def
                     |
                     |
                     +---- t8
    end
 +-- Int
 |         +--- Int -> [ Nil : t18 | Some : Int ] -> Int
 |         |
 |         |      +---- Int
 |         |      |
 |         |      |    +---- Int -> [ Nil : t18 | Some : Int ]
 |         |      |    |
 |         |      |    |   +--- Int
 |         |      |    |   |
one = withDefault 0 (#Some 1)
                     -------
                        |
                        +--- [ Nil : t18 | Some : Int ]
let
    lang = { name = "Giml", age = 0 }
in
    { website = "https://giml-lang.org" | lang }
case { name = "Giml" } of
    | { name = "Giml" } ->
        "Yeah I heard about it, funny name."

    | { name = "Haskell" } ->
        "Haskell is pretty cool!"

    | other ->
        concat (concat "I'm sure " other.name) " is pretty good too!"
end
{ <field1> : <type1>, ... | <extension-type-variable> }
Equality { a : Int | t1 } { b : Int | t2 }
Equality { a : Int | t' } t2
Equality { b : Int | t' } t1
Equality { <fields-only-found-on-the-left-side>  | new-type-var } extRight
Equality { <fields-only-found-on-the-right-side> | new-type-var } extLeft
<matched-fields>
giml = { name = "Giml", age = 0 }

getName record = record.name

gimlName = getName giml
-- Ast:

 +-- { age : Int, name : String }
 |               |
 |               |
 |     __________|_______________
giml = { name = "Giml", age = 0 }

-- Constraints:

[ Equality top0 {age : Int, name : String}
]
-- Ast:

   +--- targ4 -> t5
   |
   |               +--- targ4
   |               |
   |             __|___
getName record = record.name
                 -----------
                      |
                      +------- t5

-- Constraints:

[ Equality targ4 {name : t5 | t6}
, Equality tfun3 (targ4 -> t5)
, Equality top1 (targ4 -> t5)
]
-- Ast:

   +--- t9
   |
   |
gimlName = getName giml
              |     |
              |     |
              |     +---- top0_i8
              |
              +---- top1_i7

-- Constraints:

[ Equality top1_i7 (top0_i8 -> t9)
, Equality top2 t9
, InstanceOf top0_i8 top0
, InstanceOf top1_i7 top1
]
-- Constraints: [Equality top0 {age : Int, name : String}]
-- Substitution: []

1. Equality top0 {age : Int, name : String}
     -- => add `top0 := {age : Int, name : String}` to the substitution

-- Constraints: []
-- Substitution: [top0 := {age : Int, name : String}]
[ Equality targ4 {name : t5 | t6}
, Equality tfun3 (targ4 -> t5)
, Equality top1 (targ4 -> t5)
]
-- Constraints:
     [Equality targ4 {name : t5 | t6}, Equality tfun3 (targ4 -> t5), Equality top1 (targ4 -> t5)]
-- Substitution:
     [top0 := {age : Int, name : String}]

1. Equality targ4 {name : t5 | t6}
    -- => add `targ4 := {name : t5 | t6}` to the substitution and apply

-- Constraints:
     [Equality tfun3 ({name : t5 | t6} -> t5), Equality top1 ({name : t5 | t6} -> t5)]
-- Substitution:
     [top0 := {age : Int, name : String}, targ4 := {name : t5 | t6}]

2. Equality tfun3 ({name : t5 | t6} -> t5)
     -- => add `tfun3 := ({name : t5 | t6} -> t5)` to the substitution and apply

-- Constraints:
     [Equality top1 ({name : t5 | t6} -> t5)]
-- Substitution:
     [ top0 := {age : Int, name : String}
     , targ4 := {name : t5 | t6}
     , tfun3 := ({name : t5 | t6} -> t5)
     ]

3. Equality top1 ({name : t5 | t6} -> t5)
     -- => add `top1 := ({name : t5 | t6} -> t5)` and apply

-- Constraints:
     []
-- Substitution:
     [ top0 := {age : Int, name : String}
     , targ4 := {name : t5 | t6}
     , tfun3 := ({name : t5 | t6} -> t5)
     , top1 := ({name : t5 | t6} -> t5)
     ]
[ Equality top1_i7 (top0_i8 -> t9)
, Equality top2 t9
, InstanceOf top0_i8 top0
, InstanceOf top1_i7 top1
]
[ Equality top1_i7 (top0_i8 -> t9)
, Equality top2 t9
, InstanceOf top0_i8 {age : Int, name : String}
, InstanceOf top1_i7 ({name : t5 | t6} -> t5)
]
-- Constraints:
     [ Equality top1_i7 (top0_i8 -> t9)
     , Equality top2 t9
     , InstanceOf top0_i8 {age : Int, name : String}
     , InstanceOf top1_i7 ({name : t5 | t6} -> t5)
     ]
-- Substitution:
     [ top0 := {age : Int, name : String}
     , targ4 := {name : t5 | t6}
     , tfun3 := ({name : t5 | t6} -> t5)
     , top1 := ({name : t5 | t6} -> t5)
     ]

1. Equality top1_i7 (top0_i8 -> t9)
     -- => add `top1_i7 := (top0_i8 -> t9)`

-- Constraints:
     [ Equality top2 t9
     , InstanceOf top0_i8 {age : Int, name : String}
     , InstanceOf (top0_i8 -> t9) ({name : t5 | t6} -> t5)
     ]
-- Substitution:
     [ top0 := {age : Int, name : String}
     , targ4 := {name : t5 | t6}
     , tfun3 := ({name : t5 | t6} -> t5)
     , top1 := ({name : t5 | t6} -> t5)
     , top1_i7 := (top0_i8 -> t9)
     ]

 2. Equality top2 t9
    -- add `top2 := t9` and apply

-- Constraints:
     [ InstanceOf top0_i8 {age : Int, name : String}
     , InstanceOf (top0_i8 -> t9) ({name : t5 | t6} -> t5)
     ]
-- Substitution:
     [ top0 := {age : Int, name : String}
     , targ4 := {name : t5 | t6}
     , tfun3 := ({name : t5 | t6} -> t5)
     , top1 := ({name : t5 | t6} -> t5)
     , top1_i7 := (top0_i8 -> t9)
     , top2 := t9
     ]

 3. InstanceOf top0_i8 {age : Int, name : String}
      -- => for InstanceOf constraint we instantiate the second type
      --    and add a new Equality constraint
      --    in this case instantiation does nothing because
      --    there are no type variables on the second type
      --    so we add `Equality top0_i8 {age : Int, name : String}`
      --    which immediately turns into
      --    so we add `top0_i8 := {age : Int, name : String}`

-- Constraints:
     [ InstanceOf ({age : Int, name : String} -> t9) ({name : t5 | t6} -> t5)
     ]
-- Substitution:
     [ top0 := {age : Int, name : String}
     , targ4 := {name : t5 | t6}
     , tfun3 := ({name : t5 | t6} -> t5)
     , top1 := ({name : t5 | t6} -> t5)
     , top1_i7 := ({age : Int, name : String} -> t9)
     , top2 := t9
     , top0_i8 := {age : Int, name : String}
     ]

4. InstanceOf ({age : Int, name : String} -> t9) ({name : t5 | t6} -> t5)
     -- => new constraint:
     -- `Equality ({age : Int, name : String} -> t9) ({name : ti10 | ti11} -> ti10)`

-- Constraints:
     [ Equality ({age : Int, name : String} -> t9) ({name : ti10 | ti11} -> ti10)
     ]
-- Substitution:
     unchanged

5. Equality ({age : Int, name : String} -> t9) ({name : ti10 | ti11} -> ti10)
     -- => add constraints `Equality {age : Int, name : String} {name : ti10 | ti11}`
     --    and `Equality t9 ti10`

-- Constraints:
     [ Equality {age : Int, name : String} {name : ti10 | ti11}
     , Equality t9 ti10
     ]
-- Substitution:
     unchanged

6. Equality {age : Int, name : String} {name : ti10 | ti11}
     -- => This is a TypeRec & TypeRecExt scenario. we match the shared fields
     --    and match the row type variable with the missing fields from the typeRec
     --    adding `Equality String ti10` and `Equality ti11 { age : Int }`

-- Constraints:
     [ Equality String ti10
     , Equality ti11 { age : Int }
     , Equality t9 ti10
     ]
-- Substitution:
     [ top0 := {age : Int, name : String}
     , targ4 := {name : t5 | t6}
     , tfun3 := ({name : t5 | t6} -> t5)
     , top1 := ({name : t5 | t6} -> t5)
     , top1_i7 := ({age : Int, name : String} -> t9)
     , top2 := t9
     , top0_i8 := {age : Int, name : String}
     ]

7. Equality String ti10
   -- => ti10 := String

-- Constraints:
     [ Equality ti11 { age : Int }
     , Equality t9 String
     ]
-- Substitution:
     [ top0 := {age : Int, name : String}
     , targ4 := {name : t5 | t6}
     , tfun3 := ({name : t5 | t6} -> t5)
     , top1 := ({name : t5 | t6} -> t5)
     , top1_i7 := ({age : Int, name : String} -> t9)
     , top2 := t9
     , top0_i8 := {age : Int, name : String}
     , ti10 := String
     ]

7. Equality ti11 { age : Int }
   -- => ti11 := { age : Int }

-- Constraints:
     [ Equality t9 String
     ]
-- Substitution:
     [ top0 := {age : Int, name : String}
     , targ4 := {name : t5 | t6}
     , tfun3 := ({name : t5 | t6} -> t5)
     , top1 := ({name : t5 | t6} -> t5)
     , top1_i7 := ({age : Int, name : String} -> t9)
     , top2 := t9
     , top0_i8 := {age : Int, name : String}
     , ti10 := String
     , ti11 := { age : Int }
     ]

8. Equality t9 String
   -- =>  t9 := String

-- Constraints: []
-- Substitution:
     [ top0 := {age : Int, name : String}
     , targ4 := {name : t5 | t6}
     , tfun3 := ({name : t5 | t6} -> t5)
     , top1 := ({name : t5 | t6} -> t5)
     , top1_i7 := ({age : Int, name : String} -> String)
     , top2 := String
     , top0_i8 := {age : Int, name : String}
     , ti10 := String
     , ti11 := { age : Int }
     , t9 := String
     ]
 +-- { age : Int, name : String }
 |               |
 |               |
 |     __________|_______________
giml = { name = "Giml", age = 0 }

   +--- {name : t5 | t6} -> t5
   |
   |               +--- {name : t5 | t6}
   |               |
   |             __|___
getName record = record.name
                 -----------
                      |
                      +------- t5
   +--- String
   |
   |
gimlName = getName giml
              |     |
              |     |
              |     +---- {age : Int, name : String}
              |
              +---- {age : Int, name : String} -> String
class TypeName a where
    typeName :: a -> String

instance TypeName Bool where
    typeName _ = "Bool"

instance TypeName Int where
    typeName _ = "Int"
>>> typeName False
"Bool"
>>> typeName (0 :: Int)
"Int"
import Data.Void (Void)

instance TypeName Void where
    typeName _ = "Void"
>>> typeName (undefined :: Void)
"Void"
class Storable a where
    -- | Computes the storage requirements (in bytes) of the argument. The value
    -- of the argument is not used.
    sizeOf :: a -> Int

    …
>>> sizeOf (undefined :: Bool)
4
import Data.Proxy (Proxy(..))
import Data.Void (Void)

class TypeName a where
    typeName :: Proxy a -> String

instance TypeName Bool where
    typeName _ = "Bool"

instance TypeName Int where
    typeName _ = "Int"

instance TypeName Void where
    typeName _ = "Void"
>>> typeName (Proxy :: Proxy Bool)
"Bool"
>>> typeName (Proxy :: Proxy Int)
"Int"
>>> typeName (Proxy :: Proxy Void)
"Void"
>>> :set -XTypeApplications
>>> typeName (Proxy @Bool)
"Bool"
>>> typeName (Proxy @Int)
"Int"
>>> typeName (Proxy @Void)
"Void"
>>> typeName @Bool Proxy
"Bool"
>>> typeName @Int Proxy
"Int"
>>> typeName @Void Proxy
"Void"
import Data.Void (Void)

class TypeName a where
    typeName :: proxy a -> String
    --          ↑

instance TypeName Bool where
    typeName _ = "Bool"

instance TypeName Int where
    typeName _ = "Int"

instance TypeName Void where
    typeName _ = "Void"
>>> typeName ([] :: [Int])  -- Technically legal, but weird
"Int"
>>> data Proxy a = Proxy
>>> typeName (Proxy :: Proxy Int)
"Int"
>>> typeName @Bool Proxy
"Bool"
>>> typeName @Bool
{-# LANGUAGE AllowAmbiguousTypes #-}

import Data.Void (Void)

class TypeName a where
    typeName :: String

instance TypeName Bool where
    typeName = "Bool"

instance TypeName Int where
    typeName = "Int"

instance TypeName Void where
    typeName = "Void"
>>> :set -XTypeApplications
>>> typeName @Bool
"Bool"
>>> typeName @Int
"Int"
>>> typeName @Void
"Void"
>>> typeName :: String  -- Clearly, this type annotation is not very helpful

<interactive>:1:1: error:
    • Ambiguous type variable ‘a0’ arising from a use of ‘typeName’
      prevents the constraint ‘(TypeName a0)’ from being solved.
      Probable fix: use a type annotation to specify what ‘a0’ should be.
      These potential instances exist:
        instance [safe] TypeName Void -- Defined at Example.hs:14:10
        instance [safe] TypeName Bool -- Defined at Example.hs:8:10
        instance [safe] TypeName Int -- Defined at Example.hs:11:10
    • In the expression: typeName :: String
      In an equation for ‘it’: it = typeName :: String
testParity :: (HasReader "foo" Int m, HasState "bar" Bool m) => m ()
testParity = do
  num <- ask @"foo"
  put @"bar" (even num)
data Ctx = Ctx { foo :: Int, bar :: IORef Bool }
  deriving Generic

newtype M a = M { runM :: Ctx -> IO a }
  deriving (Functor, Applicative, Monad) via ReaderT Ctx IO
  -- Use DerivingVia to derive a HasReader instance.
  deriving (HasReader "foo" Int, HasSource "foo" Int) via
    -- Pick the field foo from the Ctx record in the ReaderT environment.
    Field "foo" "ctx" (MonadReader (ReaderT Ctx IO))
  -- Use DerivingVia to derive a HasState instance.
  deriving (HasState "bar" Bool, HasSource "bar" Bool, HasSink "bar" Bool) via
    -- Convert a reader of IORef to a state capability.
    ReaderIORef (Field "bar" "ctx" (MonadReader (ReaderT Ctx IO)))
example :: IO ()
example = do
    rEven <- newIORef False
    runM testParity (Ctx 2 rEven)
    readIORef rEven >>= print
import qualified Control.Monad.Reader as MTLReader

example :: IO ()
example = do
    let
      runTestParity :: (Int, IORef Bool) -> IO ()
      runTestParity (foo, bar) =
        flip MTLReader.runReaderT foo $
        -- Interpret the effects into 'ReaderT Int IO'.
        --
        -- Write the 'HasReader "foo" Int' dictionary
        -- in terms of mtl functions.
        --
        -- Forward the 'MonadIO' capability.
        interpret @"foo" @'[MonadIO] ReifiedReader
          { _reader = MTLReader.reader
          , _local = MTLReader.local
          , _readerSource = ReifiedSource
              { _await = MTLReader.ask }
          } $
        -- Use 'MonadIO' to write the 'HasState "bar" Bool' dictionary.
        -- Forward the 'HasReader "foo" Int' capability.
        --
        -- The 'MonadIO' capability is not forwarded, and hence forgotten.
        interpret @"bar" @'[HasReader "foo" Int] ReifiedState
          { _state = \f -> do
              b <- liftIO $ readIORef bar
              let (a, b') = f b
              liftIO $ writeIORef bar b'
              pure a
          , _stateSource = ReifiedSource
              { _await = liftIO $ readIORef bar }
          , _stateSink = ReifiedSink
              { _yield = liftIO . writeIORef bar }
          }
        testParity

    rEven <- newIORef False
    runTestParity (2, rEven)
    readIORef rEven >>= print
ReifiedReader
  { _reader = MTLReader.reader
  , _local = MTLReader.local
  , _readerSource = ReifiedSource
        { _await = MTLReader.ask }
  }
class (Monad m, HasSource tag r m) => HasReader (tag :: k) (r :: *) (m :: * -> *) | tag m -> r where
  local_ :: Proxy# tag -> (r -> r) -> m a -> m a
  reader_ :: Proxy# tag -> (r -> a) -> m a
class Monad m => HasSource (tag :: k) (a :: *) (m :: * -> *) | tag m -> a where
  await_ :: Proxy# tag -> m a
interpretFoo
  :: forall cs m a. (MTLReader.MonadReader Int m, All cs m)
  => (forall m'. All (HasReader "foo" Int : cs) m' => m' a)
  -> m a
interpretFoo =
  interpret @"foo" @cs ReifiedReader
    { _reader = MTLReader.reader
    , _local = MTLReader.local
    , _readerSource = ReifiedSource
        { _await = MTLReader.ask }
    }

interpretBar
  :: forall cs m a. (MonadIO m, All cs m)
  => IORef Bool
  -> (forall m'. All (HasState "bar" Bool : cs) m' => m' a)
  -> m a
interpretBar bar =
  interpret @"bar" @cs ReifiedState
    { _state = \f -> do
        b <- liftIO $ readIORef bar
        let (a, b') = f b
        liftIO $ writeIORef bar b'
        pure a
    , _stateSource = ReifiedSource
        { _await = liftIO $ readIORef bar }
    , _stateSink = ReifiedSink
        { _yield = liftIO . writeIORef bar }
     }
interpretBar
  :: forall cs m a. (MonadIO m, All cs m)
  => IORef Bool
  -> (forall m'. All (HasState "bar" Bool : cs) m' => m' a)
  -> m a
example :: IO ()
example = do
    let
      runTestParity :: (Int, IORef Bool) -> IO ()
      runTestParity (foo, bar) = flip MTLReader.runReaderT foo $
        interpretFoo @'[MonadIO] $
        interpretBar @'[HasReader "foo" Int] bar $
        testParity

    rEven <- newIORef False
    runTestParity (2, rEven)
    readIORef rEven >>= print
runTestParity :: (Int, IORef Bool) -> IO ()
runTestParity (foo, bar) = flip MTLReader.runReaderT foo $
  interpretFoo @'[MonadIO] $
  interpretBar @'[HasReader "foo" Int] bar $
  testParity
runTestParity :: (Int, IORef Bool) -> IO ()
runTestParity ctx = flip MTLReader.runReaderT ctx $
  derive
     -- Strategy
     @(ReaderIORef :.: Rename 2 :.: Pos 2 _ :.: MonadReader)
     -- New capability
     @'[HasState "bar" Bool]
     -- Forwarded capability
     @'[MTLReader.MonadReader (Int, IORef Bool)] $

  derive
     @(Rename 1 :.: Pos 1 _ :.: MonadReader)
     @'[HasReader "foo" Int]
     @'[HasState "bar" Bool]

  testParity
main = ffi("console.log", odd 17)

even x =
    if int_equals x 0
        then True
        else if int_equals x 1
            then False
            else odd (sub x 1)

odd x =
    if int_equals x 0
        then False
        else if int_equals x 1
            then True
            else even (sub x 1)
[["even", "odd"], ["main"]]
one = (\x -> x) 1
          +-- t1 -> t1
          |
      --------- 
one = (\x -> x) 1
 |           |  |
 +-- t2      |  +------ Int
             |
             +---- t1
[ Equality top0 t2
, Equality (t1 -> t1) (Int -> t2)
]
- Constraints: [Equality top0 t2, Equality (t1 -> t1) (Int -> t2)]
- Substitution: []

1. Equality top0 t2
    -- ==> The first is a type variable, so add `top0 := t2` to the substitution

- Constraints: [Equality (t1 -> t1) (Int -> t2)]
- Substitution: [top0 := t2]

2. Equality (t1 -> t1) (Int -> t2)
    -- ==> replace with two new constraints:
    --  1. Equality t1 Int
    --  2. Equality t1 t2

- Constraints: [Equality (-> t1) (-> Int), Equality t1 t2]
- Substitution: [top0 := t2]

3. Equality (-> t1) (-> Int)
    -- ==> replace again with two new constraints:
    --  1. Equality (->) (->)
    --  2. Equality t1 Int

- Constraints: [Equality (->) (->), Equality t1 Int, Equality t1 t2]
- Substitution: [top0 := t2]

4. Equality (->) (->)
    -- ==> these two types are identical, so we can continue

- Constraints: [Equality t1 Int, Equality t1 t2]
- Substitution: [top0 := t2]

5. Equality t1 Int
    -- ==> The first is a type variable, so add `t1 := Int` to the substitution

- Constraints: [Equality Int t2]
- Substitution: [top0 := t2, t1 := Int]

6. Equality Int t2
    -- ==> The second is a type variable, so add `t2 := Int` to the substitution

- Constraints: []
- Substitution: [top0 := Int, t1 := Int, t2 := Int]
          +-- Int -> Int
          |
      --------- 
one = (\x -> x) 1
 |           |  |
 +-- Int     |  +------ Int
             |
             +---- Int
x y = x
import Language.Java (J, JType(Class)) -- from jvm
import Language.Java.Inline (imports, java) -- from inline-java

imports "org.apache.commons.collections4.map.*"

createOrderedMap :: IO (J ('Class "org.apache.commons.collections4.OrderedMap"))
createOrderedMap = [java| new LinkedMap() |]
# file: BUILD.bazel
load(
  "@rules_haskell//haskell:defs.bzl",
  "haskell_binary",
)

haskell_binary(
    name = "example",
    srcs = ['Main.hs'],
    extra_srcs = ["@openjdk//:rpath"],
    compiler_flags = [
        "-optl-Wl,@$(location @openjdk//:libjvm.so)",
        "-threaded",
    ],
    deps = [
        "//jvm",
        "//jni",
        "//:inline-java",
        "@rules_haskell//tools/runfiles",
        "@stackage//:base",
        "@stackage//:text",
    ] + java_deps,
    data = [ ":jar_deploy.jar" ],
    plugins = ["//:inline-java-plugin"],
)

java_deps = [
    "@maven//:org_apache_commons_commons_collections4_4_1",
    ]
java_binary(
    name = "jar",
    main_class = "dummy",
    runtime_deps = java_deps,
)
import qualified Bazel.Runfiles as Runfiles
import Data.String (fromString)
import Language.Java (J, JType(Class), withJVM)
...

main = do
    r <- Runfiles.create
    let jarPath = Runfiles.rlocation r "my_workspace/example/jar_deploy.jar"
    withJVM [ "-Djava.class.path=" <> fromString jarPath ] $
      void createOrderedMap
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE TypeFamilies              #-}
import Diagrams.Prelude
import Diagrams.Backend.SVG.CmdLine
phi::Double
phi = (1.0 + sqrt 5.0) / 2.0
ttangle:: Int -> Angle Double
ttangle n = (fromIntegral (n `mod` 10))*^tt
             where tt = 1/10 @@ turn
data Component = LD (V2 Double)
               | RD (V2 Double)
               | LK (V2 Double)
               | RK (V2 Double)
ldart,rdart,lkite,rkite:: Component
ldart = LD unitX
rdart = RD unitX
lkite = LK (phi*^unitX)
rkite = RK (phi*^unitX)
compEdges:: Component -> [V2 Double]
compEdges (LD v) = [v',v ^-^ v'] where v' = phi*^rotate (ttangle 9) v
compEdges (RD v) = [v',v ^-^ v'] where v' = phi*^rotate (ttangle 1) v
compEdges (RK v) = [v',v ^-^ v'] where v' = rotate (ttangle 9) v
compEdges (LK v) = [v',v ^-^ v'] where v' = rotate (ttangle 1) v
drawComp:: Component -> Diagram B
drawComp = strokeLine . fromOffsets . compEdges
tileEdges:: Component -> [V2 Double]
tileEdges (LD v) = 
    compEdges (RD v) ++ map (zero ^-^) (reverse (compEdges (LD v)))
tileEdges (RD v) = tileEdges (LD v)
tileEdges (LK v) = 
    compEdges (LK v) ++ map (zero ^-^) (reverse (compEdges (RK v)))
tileEdges (RK v) = tileEdges (LK v)
fillDK:: Colour Double -> Colour Double -> Component -> Diagram B
fillDK dcol kcol c = case c of 
   (LD _) -> (strokeLoop $ glueLine $ fromOffsets $ tileEdges c)  # fc dcol
   (LK _) -> (strokeLoop $ glueLine $ fromOffsets $ tileEdges c)  # fc kcol
   _      -> mempty
drawJComp:: Component -> Diagram B
drawJComp = strokeLoop . closeLine . fromOffsets . compEdges
scaleComp:: Double -> Component -> Component
scaleComp = compMap . scale 
compMap f (LD v) = LD (f v)
compMap f (RD v) = RD (f v)
compMap f (LK v) = LK (f v)
compMap f (RK v) = RK (f v)
rotateComp :: Angle Double -> Component -> Component
rotateComp = compMap . rotate 
type Patch = [(V2 Double, Component)]
patchWith cd patch = position $ fmap offset patch
    where offset (v,c) = (origin .+^ v, cd c)
drawPatch = patchWith drawComp
scalePatch :: Double -> Patch -> Patch
scalePatch r = fmap (\(v,c) -> (scale r v, scaleComp r c))
rotatePatch :: Angle Double -> Patch -> Patch
rotatePatch a = fmap (\(v,c) -> (rotate a v, rotateComp a c))
translatePatch:: V2 Double -> Patch -> Patch
translatePatch v0 = fmap (\(v,c) -> (v0 ^+^ v, c))
penta:: Patch -> Patch
penta p = concatMap copy [0..4] 
            where copy n = rotatePatch (ttangle (2*n)) p
sun =  penta [(zero, rkite), (zero, lkite)]
star = penta [(zero, rdart), (zero, ldart)]
decompose :: Patch -> Patch
decompose = concatMap decompC
decompC (v, RD vd) = [(v,        LK vd  )
                     ,(v ^+^ v', RD vd' )
                     ]  where v'  = phi*^rotate (ttangle 1) vd
                              vd' = (2-phi) *^ (zero ^-^ v')
                                   -- (2-phi) = 1/phi^2

decompC (v, LD vd) = [(v,        RK vd  )
                     ,(v ^+^ v', LD vd' )
                     ]  where v'  = phi*^rotate (ttangle 9) vd
                              vd' = (2-phi) *^ (zero ^-^ v')
                                  -- (2-phi) = 1/phi^2

decompC (v, RK vk) = [(v,        RD vd' )
                     ,(v ^+^ v', LK vk' )
                     ,(v ^+^ v', RK vk' )
                     ] where v'  = rotate (ttangle 9) vk
                             vd' = (2-phi) *^ v' 
                                   -- v'/phi^2
                             vk' = ((phi-1) *^ vk) ^-^ v'
                                  -- (phi-1) = 1/phi

decompC (v, LK vk) = [(v,        LD vd' )
                     ,(v ^+^ v', RK vk' )
                     ,(v ^+^ v', LK vk' )
                     ] where v'  = rotate (ttangle 1) vk
                             vd' = (2-phi) *^ v'
                                  -- v'/phi^2
                             vk' = ((phi-1) *^ vk) ^-^ v'
                                  -- (phi-1) = 1/phi
components =  [ldart, rdart, lkite, rkite]  
fourDecomps = hsep 1 $ fmap decomps components # lw thin where
    decomps cpt = vsep 1 $ 
                  fmap drawPatch $ take 5 $ decompositions [(zero,cpt)] 
decompositions:: Patch -> [Patch]
decompositions p = inf where inf = p:fmap decompose inf
multiDecomp :: Int -> Patch -> Patch
multiDecomp n p = decompositions p !! n
suns = decompositions sun
sun6 = suns!!6
filledSun6 = patchWith (fillDK red blue) sun6 # lw ultraThin
experimentFig = patchWith experiment sun6 # lw thin
experiment:: Component -> Diagram B
experiment c = emph c <> (drawComp c # dashingN [0.002,0.002] 0 # lw ultraThin)
  where emph c = case c of
          (LD v) -> (strokeLine . fromOffsets) [v] # lc red
               -- emphasise join edge of darts in red
          (RD v) -> (strokeLine . fromOffsets) [v] # lc red 
          (LK v) -> (strokeLine . fromOffsets) [rotate (ttangle 1) v]
               -- emphasise long edge for kites
          (RK v) -> (strokeLine . fromOffsets) [rotate (ttangle 9) v]
inflate :: (V2 Double, Component) -> [(V2 Double, Component)]
inflate (v, RD vd) = [(v ^+^ v', RD vd')
                     ,(v,        RK vk )
                     ] where v'  = (phi+1) *^ vd
                                  -- vd*phi^2
                             vd' = rotate (ttangle 9) (vd ^-^ v')
                             vk  = rotate (ttangle 1) v'

inflate (v, LD vd) = [(v ^+^ v', LD vd')
                     ,(v,        LK vk )
                     ] where v'  = (phi+1) *^ vd
                                  -- vd*phi^2
                             vd' = rotate (ttangle 1) (vd ^-^ v')
                             vk  = rotate (ttangle 9) v'

inflate (v, RK vk) = [(v,         LD vk  )
                     ,(v ^+^ lv', LK lvk') 
                     ,(v ^+^ rv', RK rvk')
                     ] where lv'  = phi*^rotate (ttangle 9) vk
                             rv'  = phi*^rotate (ttangle 1) vk
                             rvk' = phi*^rotate (ttangle 7) vk
                             lvk' = phi*^rotate (ttangle 3) vk

inflate (v, LK vk) = [(v,         RD vk  )
                     ,(v ^+^ rv', RK rvk')
                     ,(v ^+^ lv', LK lvk')
                     ] where v0 = rotate (ttangle 1) vk
                             lv'  = phi*^rotate (ttangle 9) vk
                             rv'  = phi*^rotate (ttangle 1) vk
                             rvk' = phi*^rotate (ttangle 7) vk
                             lvk' = phi*^rotate (ttangle 3) vk
inflations :: Int -> (V2 Double, Component) -> [(V2 Double, Component)]
inflations 0 vc = [vc]
inflations n vc = [vc'' | vc' <- inflate vc, vc'' <- inflations (n-1) vc']
fiveInflate = hsep 1 $ fmap drawPatch [[ld,lk'], multiDecomp 5 [lk']] 
                                      -- two seperate patches 
   where 
       ld  = (zero,ldart)
       lk  = inflate ld  !!1
       rk  = inflate lk  !!1
       rk' = inflate rk  !!2
       ld' = inflate rk' !!0
       lk' = inflate ld' !!1
fig::Diagram B
fig = filledSun6
main = mainWith fig
(defvar roam-extra-original-org-agenda-files nil
  "Original value of  `org-agenda-files'.")

(defun roam-extra:update-todo-files (&rest _)
  "Update the value of `org-agenda-files'."
  (unless roam-extra-original-org-agenda-files
    (setq roam-extra-original-org-agenda-files org-agenda-files))
  (setq org-agenda-files
        (append roam-extra-original-org-agenda-files
                (roam-extra:todo-files))))

declareBareB
  [d|
   data Person = Person {name :: Text, age :: Int}
  |]

deriving instance Show (Person Covered Identity)
deriving instance Show (Person Covered Maybe)
deriving instance Show (Person Covered (Either Text))

addDefaults :: Person Covered Maybe -> Person Covered Identity -> Person Covered Identity
addDefaults = bzipWith trans
  where
    trans m d = maybe d pure m

check :: Person Covered (Either Text) -> Either [Text] (Person Covered Identity)
check pe = case btraverse (either (const Nothing) (Just . Identity)) pe of
  Just pin -> Right pin
  Nothing -> Left $ bfoldMap (either (: []) (const [])) pe

bs0, bs1 :: BSL.ByteString
bs0 = "{\"name\": \"the name\", \"age\": 17}"
bs1 = "{\"name\": \"the name\", \"age\": true}"

instance FromJSON (Person Covered Identity) where
  parseJSON = withObject "Person" $
    \o -> Person <$> o .: "name"
      <*> o .: "age"

decodePI :: BSL.ByteString -> Maybe (Person Covered Identity)
decodePI = decode

λ> let i0 = decodePI bs0
λ> i0
Just (Person {name = Identity "the name", age = Identity 17})
λ> let i1 = decodePI bs1
λ> i1
Nothing

instance FromJSON (Person Covered Maybe) where
  parseJSON = withObject "Person" $
    \o -> Person <$> (o .: "name" <|> pure Nothing)
      <*> (o .: "age" <|> pure Nothing)

decodePM :: BSL.ByteString -> Maybe (Person Covered Maybe)
decodePM = decode

λ> let m0 = decodePM bs0
λ> m0
Just (Person {name = Just "the name", age = Just 17})
λ> let m1 = decodePM bs1
λ> m1
Just (Person {name = Just "the name", age = Nothing})

instance FromJSON (Person Covered (Either Text)) where
  parseJSON = withObject "Person" $
    \o -> Person <$> ((Right <$> o .: "name") <|> pure (Left "A name is most needed"))
      <*> ((Right <$> o .: "age") <|> pure (Left "An integer age is needed"))

decodePE :: BSL.ByteString -> Maybe (Person Covered (Either Text))
decodePE = decode

λ> let e0 = decodePE bs0
λ> e0
Just (Person {name = Right "the name", age = Right 17})
λ> let e1 = decodePE bs1
λ> e1
Just (Person {name = Right "the name", age = Left "An integer age is needed"})

newtype AppM a = AppM {unAppM : ReaderT Config IO a}
  deriving
    ( Functor,
      Applicative,
      Monad,
      MonadIO,
      MonadReader Config
    )

runAppM :: AppM a -> Config -> IO a
runAppM app = runReaderT (unAppM app)

newtype AppM a = AppM {unAppM : ReaderT Config (ExceptT ServerError IO) a}
  deriving
    ( Functor,
      Applicative,
      Monad,
      MonadIO,
      MonadReader Config
    )

runAppM :: AppM a -> Config -> IO (Either ServerError a)
runAppM app = runExceptT . runReaderT (unAppM app)

nt :: AppM a -> Handler a
nt x =
  liftIO (runAppM x cfg) >>= \case
    Right v -> pure v
    Left err -> throwError err

instance MonadBaseControl IO AppM where
  type StM AppM a = Either ServerError a

  liftBaseWith f = AppM (liftBaseWith (\g -> f (g . unAppM)))
  restoreM = AppM . restoreM

{
  host = "google.com",
  port = 80,
  protocol = "http",
}
let makePort : Str -> Num = fun protocol =>
  if protocol == "http" then
    80
  else if protocol == "ftp" then
    21
  else
    null in
let unusedBad = 10 ++ "a" in
{
  port = makePort protocol,
  protocol = ("ht" ++ "tp" : Str),
}
error: Incompatible types
  ┌─ repl-input-1:7:5
  │
7 │     null in
  │     ^^^^ this expression
  │
  = The type of the expression was expected to be `Num`
  = The type of the expression was inferred to be `Dyn`
  = These types are not compatible
$nickel export <<< ...
{
  "port": 80,
  "protocol": "http"
}
let add : Num -> Num -> Num = fun x y => x + y in
add "a" 0
error: Type error
  ┌─ repl-input-0:1:26
  │
1 │ let add : Num -> Num -> Num = fun x y => x + y
  │                                              ^ This expression has type Str, but Num was expected
  │
[..]
nickel> let add : Num -> Num = fun x y => x + y in
add 5 "a"

error: Blame error: contract broken by the caller.
  ┌─ :1:8
  │
1 │ Num -> Num -> Num
  │        --- expected type of the argument provided by the caller
  │
  ┌─ repl-input-6:1:31
  │
1 │ let add : Num -> Num -> Num = fun x y => x + y
  │                               ^^^^^^^^^^^^^^^^ applied to this expression
  │
[..]
note:
  ┌─ repl-input-7:1:1
  │
1 │ add 5 "a"
  │ --------- (1) calling <func>
[..]
// this example does NOT typecheck
let f = fun x => if x then 10 else "a" in
let doStuffToNum: Num -> Num = fun arg =>
  arg + (f true) in

doStuffToNum 1
error: Incompatible types
  ┌─ repl-input-1:3:10
  │
3 │   arg + (f true) in
  │          ^ this expression
  │
  = The type of the expression was expected to be `_a -> Num`
  = The type of the expression was inferred to be `Dyn`
  = These types are not compatible
let doStuffToNum: Num -> Num = fun arg =>
  arg + (f true | Num) in
withResource 
  :: (MonadBaseControl IO m)
  => Pool a 
  -> (a -> m b) 
  -> m b
withResource pool act = control $ \runInIO -> mask $ \restore -> do
  (resource, local) <- takeResource pool
  ret <- restore (runInIO (act resource)) `onException`
            destroyResource pool local resource
  putResource local resource
  return ret

toUnliftIO 
    :: MonadUnliftIO n
    => (forall m. MonadBaseControl IO m => m a)
    -> n a
toUnliftIO mbc = 
    withRunInIO $ \runInIO -> do
        mbc

toPlainIO 
    :: (forall m. MonadBaseControl IO m => m a)
    -> IO a
toPlainIO mbc = mbc

toMonadIO 
    :: MonadIO n
    => (forall m. MonadBaseControl IO m => m a)
    -> n a
toMonadIO mbc = liftIO (toPlainIO mbc)

unsafeAcquireSqlConnFromPool = do
    pool <- MonadReader.ask

    let freeConn :: (backend, LocalPool backend) -> ReleaseType -> IO ()
        freeConn (res, localPool) relType = case relType of
            ReleaseException -> P.destroyResource pool localPool res
            _ -> P.putResource localPool res

    return $ fst <$> mkAcquireType (P.takeResource pool) freeConn

with :: MonadUnliftIO m
     => Acquire a
     -> (a -> m b)
     -> m b
with (Acquire f) g = withRunInIO $ \run -> E.mask $ \restore -> do
    Allocated x free <- f restore
    res <- restore (run (g x)) `E.onException` free ReleaseException
    free ReleaseNormal
    return res

mkAcquireType
    :: IO a -- ^ acquire the resource
    -> (a -> ReleaseType -> IO ()) -- ^ free the resource
    -> Acquire a
mkAcquireType create free = Acquire $ \_ -> do
    x <- create
    return $! Allocated x (free x)

mkAcquireType
    :: IO a -- ^ acquire the resource
    -> (a -> ReleaseType -> IO ()) -- ^ free the resource
    -> Acquire a
mkAcquireType (create = P.takeResource pool) (free = freeConn) = Acquire $ \_ -> do
    x <- (P.takeResource pool)
    return $! Allocated x (freeConn x)
  where
    freeConn (res, localPool) relType = case relType of
        ReleaseException -> P.destroyResource pool localPool res
        _ -> P.putResource localPool res

withAcquire (Acquire f) g = withRunInIO $ \run -> E.mask $ \restore -> do
    -- `f` ignores the `restore` argument: possible bug?
    Allocated x free <- f restore
    -- so `x` here comes from `P.takeResource pool`
    -- free = freeConn
    ret <- restore (run (g x)) 
        `E.onException` free ReleaseException
    free ReleaseNormal
    return ret

withAcquire (Acquire f) g = withRunInIO $ \run -> E.mask $ \restore -> do
    -- `f` ignores the `restore` argument: possible bug?
    Allocated x free <- f restore
    -- so `x` here comes from `P.takeResource pool`
    -- free = freeConn
    ret <- restore (run (g x)) 
        `E.onException` P.destroyResource pool localPool res
    P.putResource localPool res
    return ret

withAcquire (Acquire _) g = withRunInIO $ \run -> E.mask $ \restore -> do
    -- `f` ignores the `restore` argument: possible bug?
    Allocated x free <- f restore
    -- so `x` here comes from `P.takeResource pool`
    -- free = freeConn
    ret <- restore (run (g x)) 
        `E.onException` P.destroyResource pool localPool res
    P.putResource localPool res
    return ret
  where
    f _ = do
        x <- (P.takeResource pool)
        return $! Allocated x (freeConn x)

-- OK, let's splice in the definition of `f`:

withAcquire (Acquire _) g = withRunInIO $ \run -> E.mask $ \restore -> do
    -- `f` ignores the `restore` argument: possible bug?
    Allocated x free <- do
        x <- P.takeResource pool
        return $! Allocated x (freeConn x)
    -- so `x` here comes from `P.takeResource pool`
    -- free = freeConn
    ret <- restore (run (g x)) 
        `E.onException` P.destroyResource pool localPool res
    P.putResource localPool res
    return ret

-- Now let's remove the `Allocated` constructor:

withAcquire (Acquire _) g = withRunInIO $ \run -> E.mask $ \restore -> do
    x@(res, localPool) <- P.takeResource pool
    ret <- restore (run (g x)) 
        `E.onException` P.destroyResource pool localPool res
    P.putResource localPool res
    return ret

withResource 
  :: (MonadBaseControl IO m)
  => Pool a 
  -> (a -> m b) 
  -> m b
withResource pool act = 
    control $ \runInIO -> mask $ \restore -> do
      (resource, local) <- takeResource pool
      ret <- restore (runInIO (act resource)) `onException`
                destroyResource pool local resource
      putResource local resource
      return ret

acquireSqlConnFromPool
    :: (MonadReader (Pool backend) m, BackendCompatible SqlBackend backend)
    => m (Acquire backend)
acquireSqlConnFromPool = do
    connFromPool <- unsafeAcquireSqlConnFromPool
    return $ connFromPool >>= acquireSqlConn

rawAcquireSqlConn
    :: forall backend m
     . (MonadReader backend m, BackendCompatible SqlBackend backend)
    => Maybe IsolationLevel -> m (Acquire backend)
rawAcquireSqlConn isolation = do
    conn <- MonadReader.ask
    let rawConn :: SqlBackend
        rawConn = projectBackend conn

        getter :: T.Text -> IO Statement
        getter = getStmtConn rawConn

        beginTransaction :: IO backend
        beginTransaction = conn <$ connBegin rawConn getter isolation

        finishTransaction :: backend -> ReleaseType -> IO ()
        finishTransaction _ relType = case relType of
            ReleaseException -> connRollback rawConn getter
            _ -> connCommit rawConn getter

    return $ mkAcquireType beginTransaction finishTransaction

rawAcquireSqlConn
    :: Maybe IsolationLevel -> backend -> Acquire backend

instance Monad Acquire where
    return = pure
    Acquire f >>= g' = Acquire $ \restore -> do
        Allocated x free1 <- f restore
        let Acquire g = g' x
        Allocated y free2 <- g restore `E.onException` free1 ReleaseException
        return $! Allocated y (\rt -> free2 rt `E.finally` free1 rt)

\_ -> do
    x <- P.takeResource pool
    pure $ Allocated x (freeConn x)

\sqlBackend -> do
    Acquire $ \_ -> do
        _ <- beginTransaction sqlBackend getter isolation
        pure $ Allocated sqlBackend $ \case
            ReleaseException ->
                connRollback sqlBackend
            _ ->
                connCommit sqlBackend

Acquire $ \restore -> do
    Allocated x free1 <- (\_ -> do
        x <- P.takeResource pool
        pure $ Allocated x (freeConn x)) restore

    let Acquire g = g' x

    Allocated y free2 <- g restore `E.onException` free1 ReleaseException
    return $! Allocated y (\rt -> free2 rt `E.finally` free1 rt)

-- (\_ -> x) restore = x
Acquire $ \restore -> do
    Allocated x free1 <- do
        x <- P.takeResource pool
        pure $ Allocated x (freeConn x)

    let Acquire g = g' x

    Allocated y free2 <- g restore `E.onException` free1 ReleaseException
    return $! Allocated y (\rt -> free2 rt `E.finally` free1 rt)

-- float `c` and `freeConn` up
Acquire $ \restore -> do
    x <- P.takeResource pool
    let free1 = freeConn x

    let Acquire g = g' x

    Allocated y free2 <- g restore `E.onException` free1 ReleaseException
    return $! Allocated y (\rt -> free2 rt `E.finally` free1 rt)

-- inline g'
Acquire $ \restore -> do
    x <- P.takeResource pool
    let free1 = freeConn x

    let sqlBackend = x
    let Acquire g = 
            Acquire $ \_ -> do
                _ <- beginTransaction sqlBackend getter isolation
                pure $ Allocated sqlBackend $ \case
                    ReleaseException ->
                        connRollback sqlBackend
                    _ ->
                        connCommit sqlBackend

    Allocated y free2 <- g restore `E.onException` free1 ReleaseException
    return $! Allocated y (\rt -> free2 rt `E.finally` free1 rt)

-- Remove `Acquire` constructor:
Acquire $ \restore -> do
    x <- P.takeResource pool
    let free1 = freeConn x

    let sqlBackend = x
    let g _ = do
            _ <- beginTransaction sqlBackend getter isolation
            pure $ Allocated sqlBackend $ \case
                ReleaseException ->
                    connRollback sqlBackend
                _ ->
                    connCommit sqlBackend

    Allocated y free2 <- g restore `E.onException` free1 ReleaseException
    return $! Allocated y (\rt -> free2 rt `E.finally` free1 rt)

-- Inline `g`, ignore `restore` parameter
Acquire $ \restore -> do
    x <- P.takeResource pool
    let free1 = freeConn x
    let sqlBackend = x

    Allocated y free2 <-
        (do
            _ <- beginTransaction sqlBackend getter isolation
            pure $ Allocated sqlBackend $ \case
                ReleaseException ->
                    connRollback sqlBackend
                _ ->
                    connCommit sqlBackend
        ) `E.onException` free1 ReleaseException

    return $! Allocated y (\rt -> free2 rt `E.finally` free1 rt)

Acquire $ \restore -> do
    x <- P.takeResource pool
    let free1 = freeConn x
    let (sqlBackend, localPool) = x

    _ <- beginTransaction sqlBackend getter isolation
        `E.onException` free1 ReleaseException
    let free2 = \case
            ReleaseException ->
                connRollback sqlBackend
            _ ->
                connCommit sqlBackend

    return $! Allocated y (\rt -> free2 rt `E.finally` free1 rt)

-- Inline free1 and free2
Acquire $ \restore -> do
    x <- P.takeResource pool
    let (sqlBackend, localPool) = x

    _ <- beginTransaction sqlBackend getter isolation
        `E.onException` freeConn x ReleaseException

    return $! Allocated y $ \rt -> 
        (\case
            ReleaseException ->
                connRollback sqlBackend
            _ ->
                connCommit sqlBackend) rt 
        `E.finally` 
        (freeConn x rt)

-- Inline freeConn
Acquire $ \restore -> do
    x <- P.takeResource pool
    let (sqlBackend, localPool) = x

    _ <- beginTransaction sqlBackend getter isolation
        `E.onException` 
            P.destroyResource pool localPool sqlBackend

    return $! Allocated y $ \rt -> 
        (case rt of
            ReleaseException ->
                connRollback sqlBackend
            _ ->
                connCommit sqlBackend)
        `E.finally` do
            case rt of
                ReleaseException -> 
                    P.destroyResource pool localPool sqlBackend
                _ -> 
                    P.putResource localPool sqlBackend

withAcquire (Acquire f) g = withRunInIO $ \run -> E.mask $ \restore -> do
    Allocated x free <- f restore
    res <- restore (run (g x)) `E.onException` free ReleaseException
    free ReleaseNormal
    return res

-- Inline `f`. Since `restore` is never called, we can omit passing it as 
-- a parameter.
withAcquire (Acquire f) g = withRunInIO $ \run -> E.mask $ \restore -> do
    Allocated x free <- do
        x <- P.takeResource pool
        let (sqlBackend, localPool) = x

        _ <- beginTransaction sqlBackend getter isolation
            `E.onException` free1 ReleaseException

        return $! Allocated x $ \rt -> 
            (case rt of
                ReleaseException ->
                    connRollback sqlBackend
                _ ->
                    connCommit sqlBackend)
            `E.finally` do
                case rt of
                    ReleaseException -> 
                        P.destroyResource pool localPool sqlBackend
                    _ -> 
                        P.putResource localPool sqlBackend

    res <- restore (run (g x)) `E.onException` free ReleaseException
    free ReleaseNormal
    return res

-- float `x <- P.takeResource pool` to the top, and define `free` using `let`
withAcquire (Acquire f) g = withRunInIO $ \run -> E.mask $ \restore -> do
    x <- P.takeResource pool
    let free1 = freeConn x
    let (sqlBackend, localPool) = x

    _ <- beginTransaction sqlBackend getter isolation
        `E.onException` free1 ReleaseException

    let free rt = 
            (case rt of
                ReleaseException ->
                    connRollback sqlBackend
                _ ->
                    connCommit sqlBackend)
            `E.finally` do
                case rt of
                    ReleaseException -> 
                        P.destroyResource pool localPool sqlBackend
                    _ -> 
                        P.putResource localPool sqlBackend

    res <- restore (run (g x)) `E.onException` free ReleaseException
    free ReleaseNormal
    return res

-- inline `free` for each case:
withAcquire (Acquire f) g = withRunInIO $ \run -> E.mask $ \restore -> do
    x <- P.takeResource pool
    let (sqlBackend, localPool) = x

    _ <- beginTransaction sqlBackend getter isolation
        `E.onException` 
            P.destroyResource pool localPool sqlBackend

    res <- restore (run (g x)) `E.onException` do
            connRollback sqlBackend
                `E.finally`
                    P.destroyResource pool localPool sqlBackend

    do -- ReleaseNormal
        connCommit sqlBackend
            `E.finally` do
                P.putResource localPool sqlBackend
    return res

runSqlConn :: (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> backend -> m a
runSqlConn r conn = withRunInIO $ \runInIO -> mask $ \restore -> do
    let conn' = projectBackend conn
        getter = getStmtConn conn'
    restore $ connBegin conn' getter Nothing
    x <- onException
            (restore $ runInIO $ runReaderT r conn)
            (restore $ connRollback conn' getter)
    restore $ connCommit conn' getter
    return x

runSqlPool r pconn = 
    withRunInIO $ \run -> 
    withResource pconn $ run . runSqlConn r

-- expand lambda
runSqlPool r pconn = 
    withRunInIO $ \run -> 
    withResource pconn $ \conn -> 
    run $ runSqlConn r conn

-- inline runSqlConn
runSqlPool r pconn = 
    withRunInIO $ \run -> 
    withResource pconn $ \conn -> 
    run $ withRunInIO $ \runInIO -> 
    mask $ \restore -> do
        let conn' = projectBackend conn
            getter = getStmtConn conn'
        restore $ connBegin conn' getter Nothing
        x <- onException
                (restore $ runInIO $ runReaderT r conn)
                (restore $ connRollback conn' getter)
        restore $ connCommit conn' getter
        return x

-- abstract action to a variable
runSqlPool r pconn = 
    withRunInIO $ \run -> 
    withResource pconn $ \conn -> 
    let act = 
            run $ withRunInIO $ \runInIO -> 
            mask $ \restore -> do
                let conn' = projectBackend conn
                    getter = getStmtConn conn'
                restore $ connBegin conn' getter Nothing
                x <- onException
                        (restore $ runInIO $ runReaderT r conn)
                        (restore $ connRollback conn' getter)
                restore $ connCommit conn' getter
                return x
     in act

-- inline withResource

runSqlPool r pconn =
    withRunInIO $ \run -> 
    -- withResource pconn $ \conn ->
    control $ \runInIO0 -> 
    mask $ \restore0 -> do
        let act conn = 
                run $ withRunInIO $ \runInIO1 -> 
                mask $ \restore1 -> do
                    let conn' = projectBackend conn
                        getter = getStmtConn conn'
                    restore1 $ connBegin conn' getter Nothing
                    x <- onException
                            (restore1 $ runInIO1 $ runReaderT r conn)
                            (restore1 $ connRollback conn' getter)
                    restore1 $ connCommit conn' getter
                    return x
        (resource, local) <- takeResource pool
        ret <- restore0 (runInIO0 (act resource)) `onException`
                  destroyResource pool local resource
        putResource local resource
        return ret

-- inline `act`
runSqlPool r pconn =
    withRunInIO $ \run -> 
    -- withResource pconn $ \conn ->
    control $ \runInIO0 -> 
    mask $ \restore0 -> do
        (resource, local) <- takeResource pool
        ret <- restore0 (runInIO0 (
            run $ withRunInIO $ \runInIO1 -> 
            mask $ \restore1 -> do
                let conn = resource
                let conn' = projectBackend conn
                    getter = getStmtConn conn'
                restore1 $ connBegin conn' getter Nothing
                x <- onException
                        (restore1 $ runInIO1 $ runReaderT r conn)
                        (restore1 $ connRollback conn' getter)
                restore1 $ connCommit conn' getter
                return x)) `onException`
                  destroyResource pool local resource
        putResource local resource
        return ret

mask $ \restore -> do
    restore $ do
        mask $ \restore' -> do
            ...

runSqlPool r pconn =
    -- Unmasked
    withRunInIO $ \run -> 
    control $ \runInIO0 -> 
    mask $ \restore0 -> do
        -- Masked
        (resource, local) <- takeResource pool
        ret <- restore0 
            -- Unmasked
            (runInIO0 $ run $ withRunInIO $ \runInIO1 ->
            -- Masked
            mask $ \restore1 -> do
                let conn = resource
                let conn' = projectBackend conn
                    getter = getStmtConn conn'
                -- Unmasked
                restore1 $ connBegin conn' getter Nothing
                x <- onException
                                    -- Unmasked
                        (restore1 $ runInIO1 $ runReaderT r conn)
                                    -- Unmasked
                        (restore1 $ connRollback conn' getter)
                restore1 $ do --unmasked
                    connCommit conn' getter
                return x)
                -- Masked
                `onException`
                  destroyResource pool local resource
        -- Still masked
        putResource local resource
        return ret

myexecutable +RTS --nonmoving-gc
writeFizzBuzzResults :: [String] -> IO ()
writeFizzBuzzResults results = mapM_ putStrLn results
(add-hook 'org-roam-file-setup-hook #'roam-extra:update-todo-tag)
(add-hook 'before-save-hook #'roam-extra:update-todo-tag)

(advice-add 'org-agenda :before #'roam-extra:update-todo-files)

(defun roam-extra:todo-p ()
  "Return non-nil if current buffer has any TODO entry.

TODO entries marked as done are ignored, meaning the this
function returns nil if current buffer contains only completed
tasks."
  (org-element-map
      (org-element-parse-buffer 'headline)
      'headline
    (lambda (h)
      (eq (org-element-property :todo-type h)
          'todo))
    nil 'first-match))

(defun roam-extra:update-todo-tag ()
  "Update TODO tag in the current buffer."
  (when (and (not (active-minibuffer-window))
             (org-roam--org-file-p buffer-file-name))
    (let* ((file (buffer-file-name (buffer-base-buffer)))
           (all-tags (org-roam--extract-tags file))
           (prop-tags (org-roam--extract-tags-prop file))
           (tags prop-tags))
      (if (roam-extra:todo-p)
          (setq tags (seq-uniq (cons "todo" tags)))
        (setq tags (remove "todo" tags)))
      (unless (equal prop-tags tags)
        (org-roam--set-global-prop
         "roam_tags"
         (combine-and-quote-strings tags))))))

(defun roam-extra:todo-files ()
  "Return a list of note files containing todo tag."
  (seq-map
   #'car
   (org-roam-db-query
    [:select file
             :from tags
             :where (like tags (quote "%\"todo\"%"))])))

(defun roam-extra:update-todo-files (&rest _)
  "Update the value of `org-agenda-files'."
  (setq org-agenda-files (roam-extra:todo-files)))

newtype a -&> b = Hyp { invoke :: (b -&> a) -> b } 
type a -&> b = (b -&> a) -> b
             = ((a -&> b) -> a) -> b
             = (((b -&> a) -> b) -> a) -> b
             = ((((... -> b) -> a) -> b) -> a) -> b
((((... -> b) -> a) -> b) -> a) -> b
           +     -     +     -     +
zip :: [a] -> [b] -> [(a,b)]
zip xs ys = foldr xf xb xs (foldr yf yb ys)
  where
    xf x xk yk = yk x xk
    xb _ = []

    yf y yk x xk = (x,y) : xk yk
    yb _ _ = []
â€¢ Occurs check: cannot construct the infinite type:
    t0 ~ a -> (t0 -> [(a, b)]) -> [(a, b)]
newtype Zip a b = 
  Zip { runZip :: a -> (Zip a b -> [(a,b)]) -> [(a,b)] }

zip :: forall a b. [a] -> [b] -> [(a,b)]
zip xs ys = xz yz
  where
    xz :: Zip a b -> [(a,b)]
    xz = foldr f b xs
      where    
        f x xk yk = runZip yk x xk
        b _ = []

    yz :: Zip a b
    yz = foldr f b ys
      where
        f y yk = Zip (\x xk -> (x,y) : xk yk)
        b = Zip (\_ _ -> [])
zip :: forall a b. [a] -> [b] -> [(a,b)]
zip xs ys = invoke xz yz
  where
    xz :: (a -> [(a,b)]) -&> [(a,b)]
    xz = foldr f b xs
      where
        f x xk = Hyp (\yk -> invoke yk xk x)
        b = Hyp (\_ -> [])

    yz :: [(a,b)] -&> (a -> [(a,b)]) 
    yz = foldr f b ys
      where
        f y yk = Hyp (\xk x -> (x,y) : invoke xk yk)
        b = Hyp (\_ _ -> [])
data Tree a = a :& [Tree a]

newtype Q a = Q { q :: (Q a -> [a]) -> [a] }

bfe :: Tree a -> [a]
bfe t = q (f t b) e
  where
    f :: Tree a -> Q a -> Q a
    f (x :& xs) fw = Q (\bw -> x : q fw (bw . flip (foldr f) xs))

    b :: Q a
    b = Q (\k -> k b)

    e :: Q a -> [a]
    e (Q q) = q e
bfe :: Tree a -> [a]
bfe t = invoke (f t e) e
  where
    f :: Tree a -> ([a] -&> [a]) -> ([a] -&> [a])
    f (x :& xs) fw = Hyp (\bw -> x : invoke fw (Hyp (invoke bw . flip (foldr f) xs)))

    e :: [a] -&> [a]
    e = Hyp (\k -> invoke k e)
bfe t = invoke (f t e) e 1
  where
    f :: Tree a -> (Int -> [a]) -&> (Int -> [a]) 
                -> (Int -> [a]) -&> (Int -> [a])
    f (x :& xs) fw =
      Hyp (\bw n -> x :
            invoke fw
              (Hyp (invoke bw . flip (foldr f) xs)) (n+1))

    e :: (Int -> [a]) -&> (Int -> [a])
    e = Hyp b

    b x 0 = []
    b x n = invoke x (Hyp b) (n-1)
newtype ProdPar a b = ProdPar (ConsPar a b -> b) 
newtype ConsPar a b = ConsPar (a -> ProdPar a b -> b)
fromP :: ProdPar a b -> (a -> b) -&> b
fromP (ProdPar x) = Hyp (x . toC)

toC ::  b -&> (a -> b) -> ConsPar a b
toC (Hyp h) = ConsPar (\x p -> h (fromP p) x)

toP :: (a -> b) -&> b -> ProdPar a b
toP (Hyp x) = ProdPar (x . fromC)

fromC :: ConsPar a b -> b -&> (a -> b)
fromC (ConsPar p) = Hyp (\h x -> p x (toP h))
record _â†¬_ (A : Type a) (B : Type b) : Type (a â„“âŠ” b) where
  inductive; constructor hyp
  field invoke : (B â†¬ A) â†’ B
yes? : âŠ¥ â†¬ âŠ¥
yes? .invoke h = h .invoke h

no! : (âŠ¥ â†¬ âŠ¥) â†’ âŠ¥
no! h = h .invoke h

boom : âŠ¥
boom = no! yes?
record _â†¬_ (A : Type a) (B : Type b) : Type (a â„“âŠ” b) where
  inductive; constructor hyp
  field invoke : ((A â†¬ B) â†’ A) â†’ B
data Rou
  = Over
  | Next ((Rou -> [Int]) -> [Int])
instance Category (-&>) where
  id = Hyp (\k -> invoke k id)
  f . g = Hyp (\k -> invoke f (g . k))
push :: (a -> b) -> a -&> b -> a -&> b
push f q = Hyp (\k -> f (invoke k q))
push f p . push g q â‰¡ push (f . g) (p . q)
invoke (push f p) q â‰¡ f (invoke q p)
run :: a -&> a -> a
run f = invoke f id
bfe :: Tree a -> [a]
bfe = run . f
  where
    f (x :& xs) = push (x:) (zips (map f xs))

    zips = foldr (.) id
instance Monad ((-&>) a) where
  m >>= f = Hyp (\k -> invoke (f (invoke m (Hyp (invoke k . (>>=f))))) k)
newtype HypM m a b = HypM { invokeM :: m ((HypM m a b -> a) -> b) }
bfe t = r (f t e)
  where
    f :: Tree a -> HypM Maybe [a] [a] -> HypM Maybe [a] [a]
    f (x :& xs) fw = HypM (Just (\bw -> x : fromMaybe (\k -> k e) (invokeM fw) (bw . flip (foldr f) xs)))

    e :: HypM Maybe [a] [a]
    e = HypM Nothing

    r :: HypM Maybe [a] [a] -> [a]
    r = maybe [] (\k -> k r) . invokeM
newtype ListT m a = ListT { runListT :: forall b. (a -> m b -> m b) -> m b -> m b }
zipM :: Monad m => ListT m a -> ListT m b -> ListT m (a,b)
zipM xs ys = ListT (\c n ->
  let
    xf x xk = pure (\yk -> yk (HypM xk) x)
    xb = pure (\_ -> n)

    yf y yk = pure (\xk x -> c (x, y) (join (invokeM xk <*> yk)))
    yb = pure (\_ _ -> n)
  in join (runListT xs xf xb <*> runListT ys yf yb))
newtype HypP p a b = HypP { invokeP :: p (HypP p b a) b }
hyper = { version = "0.14", features = ["full"] }
tokio = { version = "1", features = ["full"] }

use std::convert::Infallible;
use std::net::SocketAddr;
use hyper::{Body, Request, Response, Server};
use hyper::service::{make_service_fn, service_fn};

async fn hello_world(_req: Request<Body>) -> Result<Response<Body>, Infallible> {
    Ok(Response::new("Hello, World".into()))
}

#[tokio::main]
async fn main() {
    // We'll bind to 127.0.0.1:3000
    let addr = SocketAddr::from(([127, 0, 0, 1], 3000));

    // A `Service` is needed for every connection, so this
    // creates one from our `hello_world` function.
    let make_svc = make_service_fn(|_conn| async {
        // service_fn converts our function into a `Service`
        Ok::<_, Infallible>(service_fn(hello_world))
    });

    let server = Server::bind(&addr).serve(make_svc);

    // Run this server for... forever!
    if let Err(e) = server.await {
        eprintln!("server error: {}", e);
    }
}

use std::sync::{Arc, Mutex};

type Counter = Arc<Mutex<usize>>; // Bonus points: use an AtomicUsize instead

async fn hello_world(counter: Counter, _req: Request<Body>) -> Result<Response<Body>, Infallible> {
    let mut guard = counter.lock().unwrap(); // unwrap poisoned Mutexes
    *guard += 1;
    let message = format!("You are visitor number {}", guard);
    Ok(Response::new(message.into()))
}

let addr = SocketAddr::from(([127, 0, 0, 1], 3000));
let counter: Counter = Arc::new(Mutex::new(0));

let make_svc = make_service_fn(|_conn| async {
    Ok::<_, Infallible>(service_fn(|req| hello_world(counter, req)))
});

let server = Server::bind(&addr).serve(make_svc);

if let Err(e) = server.await {
    eprintln!("server error: {}", e);
}

error[E0507]: cannot move out of `counter`, a captured variable in an `FnMut` closure
  --> src\main.rs:21:58
   |
18 |     let counter: Counter = Arc::new(Mutex::new(0));
   |         ------- captured outer variable
...
21 |         Ok::<_, Infallible>(service_fn(|req| hello_world(counter, req)))
   |                                                          ^^^^^^^ move occurs because `counter` has type `Arc<std::sync::Mutex<usize>>`, which does not implement the `Copy` trait

error[E0507]: cannot move out of `counter`, a captured variable in an `FnMut` closure
  --> src\main.rs:20:50
   |
18 |       let counter: Counter = Arc::new(Mutex::new(0));
   |           ------- captured outer variable
19 |
20 |       let make_svc = make_service_fn(|_conn| async {
   |  __________________________________________________^
21 | |         Ok::<_, Infallible>(service_fn(|req| hello_world(counter, req)))
   | |                                        -------------------------------
   | |                                        |
   | |                                        move occurs because `counter` has type `Arc<std::sync::Mutex<usize>>`, which does not implement the `Copy` trait
   | |                                        move occurs due to use in generator
22 | |     });
   | |_____^ move out of `counter` occurs here

Ok::<_, Infallible>(service_fn(|req| hello_world(counter, req)))

Ok::<_, Infallible>(service_fn(|req| hello_world(counter.clone(), req)))

error[E0597]: `counter` does not live long enough
  --> src\main.rs:21:58
   |
20 |       let make_svc = make_service_fn(|_conn| async {
   |  ____________________________________-------_-
   | |                                    |
   | |                                    value captured here
21 | |         Ok::<_, Infallible>(service_fn(|req| hello_world(counter.clone(), req)))
   | |                                                          ^^^^^^^ borrowed value does not live long enough
22 | |     });
   | |_____- returning this value requires that `counter` is borrowed for `'static`
...
29 |   }
   |   - `counter` dropped here while still borrowed

let make_svc = make_service_fn(move |_conn| async move {
    Ok::<_, Infallible>(service_fn(move |req| hello_world(counter.clone(), req)))
});

error[E0507]: cannot move out of `counter`, a captured variable in an `FnMut` closure
  --> src\main.rs:20:60
   |
18 |       let counter: Counter = Arc::new(Mutex::new(0));
   |           ------- captured outer variable
19 |
20 |       let make_svc = make_service_fn(move |_conn| async move {
   |  ____________________________________________________________^
21 | |         Ok::<_, Infallible>(service_fn(move |req| hello_world(counter.clone(), req)))
   | |                                        --------------------------------------------
   | |                                        |
   | |                                        move occurs because `counter` has type `Arc<std::sync::Mutex<usize>>`, which does not implement the `Copy` trait
   | |                                        move occurs due to use in generator
22 | |     });
   | |_____^ move out of `counter` occurs here

let make_svc = make_service_fn(move |_conn| async move {
    let counter_clone = counter.clone();
    Ok::<_, Infallible>(service_fn(move |req| hello_world(counter_clone.clone(), req)))
});

error[E0507]: cannot move out of `counter`, a captured variable in an `FnMut` closure
  --> src\main.rs:20:60
   |
18 |       let counter: Counter = Arc::new(Mutex::new(0));
   |           ------- captured outer variable
19 |
20 |       let make_svc = make_service_fn(move |_conn| async move {
   |  ____________________________________________________________^
21 | |         let counter_clone = counter.clone();
   | |                             -------
   | |                             |
   | |                             move occurs because `counter` has type `Arc<std::sync::Mutex<usize>>`, which does not implement the `Copy` trait
   | |                             move occurs due to use in generator
22 | |         Ok::<_, Infallible>(service_fn(move |req| hello_world(counter_clone.clone(), req)))
23 | |     });
   | |_____^ move out of `counter` occurs here

let make_svc = make_service_fn(move |_conn| async move {
    let counter_clone = counter.clone();
    Ok::<_, Infallible>(service_fn(move |req| hello_world(counter_clone.clone(), req)))
});

let make_svc = make_service_fn(move |_conn| { // outer closure
    async move { // async block
        let counter_clone = counter.clone();
        Ok::<_, Infallible>(service_fn(move |req| { // inner closure
            hello_world(counter_clone.clone(), req)
        }))
    }
});

let make_svc = make_service_fn(move |_conn| {
    async {
        let counter_clone = counter.clone();
        Ok::<_, Infallible>(service_fn(move |req| {
            hello_world(counter_clone.clone(), req)
        }))
    }
});

error: captured variable cannot escape `FnMut` closure body
  --> src\main.rs:21:9
   |
18 |       let counter: Counter = Arc::new(Mutex::new(0));
   |           ------- variable defined here
19 |
20 |       let make_svc = make_service_fn(move |_conn| {
   |                                                 - inferred to be a `FnMut` closure
21 | /         async {
22 | |             let counter_clone = counter.clone();
   | |                                 ------- variable captured here
23 | |             Ok::<_, Infallible>(service_fn(move |req| {
24 | |                 hello_world(counter_clone.clone(), req)
25 | |             }))
26 | |         }
   | |_________^ returns an `async` block that contains a reference to a captured variable, which then escapes the closure body
   |
   = note: `FnMut` closures only have access to their captured variables while they are executing...
   = note: ...therefore, they cannot allow references to captured variables to escape

let make_svc = make_service_fn(move |_conn| {
    let counter_clone = counter.clone(); // this moved one line earlier
    async move {
        Ok::<_, Infallible>(service_fn(move |req| {
            hello_world(counter_clone.clone(), req)
        }))
    }
});

    * Couldn't match type `m' with `m0'
    * No instance for (KnownNat m0) arising from a use of `five'
fn weird_function(iter: impl IntoIterator<Item=u32>) {
    for x in iter.into_iter().map(|x| x * 2) {
        println!("{}", x);
    }
}

fn main() {
    weird_function(1..10);
}

fn weird_function(iter: impl IntoIterator<Item=u32>) {
    for x in iter.into_iter().map(|x| x * 2) {
        if x == 8 { return } // added this line
        println!("{}", x);
    }
}

fn weird_function(iter: impl IntoIterator<Item=u32>) {
    iter.into_iter().map(|x| x * 2).for_each(|x| {
        println!("{}", x);
    })
}

fn weird_function(iter: impl IntoIterator<Item=u32>) {
    iter.into_iter().map(|x| x * 2).map(|x| {
        println!("{}", x);
    })
}

error[E0308]: mismatched types
 --> src\main.rs:2:5
  |
2 | /     iter.into_iter().map(|x| x * 2).map(|x| {
3 | |         println!("{}", x);
4 | |     })
  | |______^ expected `()`, found struct `Map`

fn weird_function(iter: impl IntoIterator<Item=u32>) {
    iter.into_iter().map(|x| x * 2).map(|x| {
        println!("{}", x);
    }).collect()
}

fn weird_function(iter: impl IntoIterator<Item=u32>) {
    iter.into_iter().map(|x| x * 2).map(|x| {
        if x == 8 { return }
        println!("{}", x);
    }).collect()
}

2
4
6
10
12
14
16
18

fn weird_function(iter: impl IntoIterator<Item=u32>) -> Option<()> {
    iter.into_iter().map(|x| x * 2).map(|x| {
        if x == 8 { return None } // short circuit!
        println!("{}", x);
        Some(()) // keep going!
    }).collect()
}

fn weird_function(iter: impl IntoIterator<Item=u32>) -> Option<Vec<u32>> {
    iter.into_iter().map(|x| x * 2).map(|x| {
        if x == 8 { return None } // short circuit!
        println!("{}", x);
        Some(x) // keep going!
    }).collect()
}

fn weird_function(iter: impl IntoIterator<Item=u32>) -> Option<u32> {
    iter.into_iter().map(|x| x * 2).map(|x| {
        if x == 8 { return None } // short circuit!
        println!("{}", x);
        Some(x) // keep going!
    }).sum()
}

#[derive(Debug)]
enum Short {
    Stopped,
    Completed,
}

impl<T> std::iter::Sum<Option<T>> for Short {
    fn sum<I: Iterator<Item = Option<T>>>(iter: I) -> Self {
        for x in iter {
            if let None = x { return Short::Stopped }
        }
        Short::Completed
    }
}
fn weird_function(iter: impl IntoIterator<Item=u32>) -> Short {
    iter.into_iter().map(|x| x * 2).map(|x| {
        if x == 8 { return None } // short circuit!
        println!("{}", x);
        Some(x) // keep going!
    }).sum()
}

fn main() {
    println!("{:?}", weird_function(1..10));
}

use std::iter::FromIterator;

#[derive(Debug)]
enum Short {
    Stopped,
    Completed,
}

impl<T> FromIterator<Option<T>> for Short {
    fn from_iter<I: IntoIterator<Item = Option<T>>>(iter: I) -> Self {
        for x in iter {
            if let None = x { return Short::Stopped }
        }
        Short::Completed
    }
}
fn weird_function(iter: impl IntoIterator<Item=u32>) -> Short {
    iter.into_iter().map(|x| x * 2).map(|x| {
        if x == 8 { return None } // short circuit!
        println!("{}", x);
        Some(x) // keep going!
    }).collect()
}

fn main() {
    println!("{:?}", weird_function(1..10));
}

from itertools import islice, product
from collections import Counter

def mk_neighbs(point):
    """Return neighboring points, with the original point first

    (1, 2)
    => [(1, 2), (1, 1), (1, 3), (0, 2), (0, 1), (0, 3), (2, 2), (2, 1), (2, 3)]
    """
    return list(product(*[[x, x-1, x+1] for x in point]))

def step_naive(pts):
    """Takes a set of points (tuples) and steps them in the simulation
    """
    neighbs = Counter()
    for point in pts:
        # skip the first item, the original point
        neighbs += Counter(mk_neighbs(point)[1:])

    def validate(point, ncount):
        if point in pts:
            return ncount == 2 or ncount == 3
        else:
            return ncount == 3

    return frozenset(p for p, n in neighbs.items() if validate(p, n))
def axis_weight(source,target):
    """Retuns how many times the given source->target transition should be
    counted in target's neighbor count
    """
    # ignore x,y
    higher_source = source[2:]
    higher_target = target[2:]
    return 2**sum([1 for i,j in zip(higher_source, higher_target)
                      if i == 1 and j == 0
                  ])

def mk_positive_neighbs(point):
    """mk_neighbs, but only with positive higher dimensional points
    """
    # this is a very wasteful implementation, for demonstrative purposes
    return [ngb for ngb in mk_neighbs(point) if all (i >= 0 for i in ngb[2:])]

def step_axis(pts):
    """Takes a set of points (tuples) and steps them in the simulation
    according to axis-reflection symmetry.
    """
    neighbs = Counter()
    for point in pts:
        neighbs += Counter({ ngb: axis_weight(point,ngb)
                               for ngb in mk_positive_neighbs(point)[1:]
                           })

    def validate(point, ncount):
        if point in pts:
            return ncount == 2 or ncount == 3
        else:
            return ncount == 3

    return frozenset(p for p, n in neighbs.items() if validate(p, n))
def normalize(point):
    """Normalize a point by sorting the absolute values

    (2, -1)
    => (1, 2)
    """
    return tuple(sorted([abs(x) for x in point]))

def forward_neighbs(point):
    """Generate the higher-dimensional forward neighbors of a point

    (0, 1)
    => {(0, 1): 2, (1, 2): 2, (1, 1): 2, (0, 0): 1, (0, 2): 1}
    """
    return Counter([normalize(neighb) for neighb in mk_neighbs(point)[1:]])
def reverse_neighbs_table(t_max):
    """Tabulate the reverse neighbors of all zw slices reachable before t_max
    """
    weights = {}

    for i in range(t_max):
        for j in range(i, t_max):
            for neighb, ncount in forward_neighbs((i, j)).items():
                if neighb in weights:
                    weights[neighb][(i, j)] = ncount
                else:
                    weights[neighb] = {(i, j): ncount}

    return weights
def reverse_neighbs(point):
    """Return normalized higher-dimensional points, with their reverse
    multiplicities

    (0, 1)
    => {(0, 0): 4, (0, 1): 2, (1, 1): 2, (0, 2): 1, (1, 2): 1}
    """
    # implementation elided
    # one possibility is to lookup into reverse_neighbs_table(t_max)[point]
    return {}

def step_with_weights(pts):
    neighbs = Counter()
    for point in pts:
        # 2d component, <x,y>
        pt_2d = point[:2]
        # higher-dimension components, <z,w,...>
        pt_nd = point[2:]

        # insert neighbors in the same 2d slice, not including itself
        neighbs += Counter([ngb + pt_nd for ngb in mk_neighbs(pt_2d)[1:]])
        # insert neighbors in the neighboring 2d slices
        neighbs += Counter({(ngb_2 + ngb_n): wt
                                for ngb_n, wt in reverse_neighbs(pt_nd)
                                for ngb_2 in mk_neighbs(pt_2d)
                          })

    def validate(point, ncount):
        if point in pts:
            return ncount == 2 or ncount == 3
        else:
            return ncount == 3

    return frozenset(p for p, n in neighbs.items() if validate(p, n))
2020-12-19 02:32:42   jle`    | d=10 in 9m58s
2020-12-19 02:33:05   jle`    | hooray my goal :)
2020-12-19 02:33:08   jle`    | time to sleep now
2020-12-19 02:33:12   xerox_  | goodnight
2020-12-19 02:33:35   jle`    | xerox_: thanks :)
{<1,2,1,1,3>, <3,1,1,1,4>, <1,2,0,0,5>, <4,2,3,4,4>, <3,1,2,2,2>}
<1,2>: { <1,1,3>, <0,0,5> }
<3,1>: { <1,1,4>, <2,2,2> }
<4,2>: { <3,3,4> }
def step_with_stacks(stacks):
    neighbs = {}
    for pt_2d, pt_stack in stacks.items():
        # higher-dimension components
        for pt_nd in pt_stack:
            rev_neighbs = Counter(reverse_neighbs(pt_nd))
            rev_neighbs_incl_self = rev_neighbs + Counter(pt_nd)

            # the actual propagation
            # 1. add in the same stack; don't include self
            if pt_2d in neighbs:
                neighbs[pt_2d] += rev_neighbs
            else:
                neighbs[pt_2d] = rev_neighbs
            # 2. add to nieghboring stacks; include self
            for ngb_2 in mk_neighbs(pt_2d)[1:]:
                if ngb_2 in neighbs:
                    neighbs[ngb_2] += rev_neighbs_incl_self
                else:
                    neighbs[ngb_2] = rev_neighbs_incl_self

    def validate(pt_2d, pt_nd, ncount):
        if pt_nd in stacks[pt_2d]:
            return ncount == 2 or ncount == 3
        else:
            return ncount == 3

    return {pt_2d: frozenset(
                       pt_nd for pt_nd, n in pt_counts.items()
                             if validate(pt_2d, pt_nd, n)
                   )
              for pt_2d, pt_counts in neighbs
           }
def step_with_stack_cache(stacks):
    neighbs = {}
    stack_cache = {}

    for pt_2d, pt_stack in stacks.items():
        # get what to place in the same xy cell, and what to place in neighbor
        # xy cells
        if pt_stack in stack_cache:
            # get it from the cache if it exists
            (rev_neighbs, rev_neighbs_incl_self) = stack_cache[pt_stack]
        else:
            # otherwise, build it and store it in the cache
            rev_neighbs = Counter()
            for pt_nd in pt_stack:
                rev_neighbs += Counter(reverse_neighbs(pt_nd))
            rev_neighbs_incl_self = rev_neighbs + Counter(pt_stack)
            stack_cache[pt_stack] = (rev_neighbs, rev_neighbs_incl_self)

        # the actual propagation
        # 1. add in the same stack; don't include self
        if pt_2d in neighbs:
            neighbs[pt_2d] += rev_neighbs
        else:
            neighbs[pt_2d] = rev_neighbs
        # 2. add to nieghboring stacks; include self
        for ngb_2 in mk_neighbs(pt_2d)[1:]:
            if ngb_2 in neighbs:
                neighbs[ngb_2] += rev_neighbs_incl_self
            else:
                neighbs[ngb_2] = rev_neighbs_incl_self

    def validate(pt_2d, pt_nd, ncount):
        if pt_2d in stacks and pt_nd in stacks[pt_2d]:
            return ncount == 2 or ncount == 3
        else:
            return ncount == 3

    return {pt_2d: frozenset(
                       pt_nd for pt_nd, n in pt_counts.items()
                             if validate(pt_2d, pt_nd, n)
                   )
              for pt_2d, pt_counts in neighbs
           }
{-# LANGUAGE ApplicativeDo #-}
showAnInt :: Applicative f => f Int -> f String
showAnInt action = do
  n <- action
  return $ show n
-- Note the 'Functor' constraint rather than 'Applicative'.
showAnIntFunctor :: Functor f => f Int -> f String
showAnIntFunctor action = do
  n <- action
  return $ show n
applyToPackage box action = do
  x <- box
  action x
-- Note the 'Monad' constraint despite us having switched on 'ApplicativeDo'
applyToPackage :: Monad f => f a -> (a -> f b) -> f b
-- NB: No constraints on 'f' are required.
justDoIt :: f Int -> f Int
justDoIt action = do
  action
pure1 = return
pure2 x = do
  return x
pure3 x = do
  y <- pure x
  return x
pure4 x = do
  y <- return x
  return x
pure1 :: Monad f => a -> f a
pure2 :: Monad f => a -> f a
pure3 :: Applicative f => a -> f a
pure4 :: Monad f => a -> f a
constrainedId xM = do
  x <- xM
  pure x
constrainedId :: Functor f => f a -> f a
unpackAndApply1 gM xyF = do
  (i, _) <- xyF
  g <- gM
  return $ g i
unpackAndApply1 :: Monad f => f (Int -> a) -> f (Int, String) -> f a
unpackAndApply2 gM xyF =
  gM <*> (fst <$> xyF)
unpackAndApply2 :: Applicative f => f (Int -> a) -> f (Int, String) -> f a
unpackAndApply3 gM xyF = do
  ~(i, _) <- xyF
  g <- gM
  return $ g i
unpackAndApply3 :: Applicative f => f (Int -> a) -> f (Int, String) -> f a
unpackAndApply4 gM xyF = do
  x'y <- xyF
  g <- gM
  return $ g (fst x'y) -- now the unpacking happens here
unpackAndApply4 :: Applicative f => f (Int -> a) -> f (Int, String) -> f a
variant1 xM xM' f f' = do
  x <- xM
  y <- f x
  x' <- xM'
  y' <- f' x'
  return (y, y')
variant2 xM xM' f f' = do
  x <- xM
  x' <- xM' -- note this line being executed earlier,
  y <- f x  -- ... before the call to 'f'
  y' <- f' x'
  return (y, y')

Name	Description	`GHC.Stats`	Eventlog
Live Bytes	The amount of live heap allocated data in your program	`gcdetails_live_bytes`	`HeapLive`
Heap Size	The amount of memory the RTS is currently retaining for the Haskell heap	`gcdetails_mem_in_use_bytes`	`HeapSize`
OS VmRSS	The amount of memory the OS thinks your program is using	Sample from `/proc/pid/status`	–

Number	Block contents
0	`A` has 1000 sprockets available
1	`B` has 500 springs available
2	`A` looking for a supplier of 300 springs
3	`C` agrees to buy 100 sprockets from `A` at €2/sprocket

Block contents	Signed by
`A` has 1000 sprockets available	`A`
`B` has 500 springs available	`B`
`A` looking for a supplier of 300 springs	`A`
`C` agrees to buy 100 sprockets from `A` at €2/sprocket	`A`, `C`

Block contents	Signed by
`A` has 1000 sprockets available	`A`
`B` has 500 springs available	`B`
`A` looking for a supplier of 300 springs	`A`
`C` agrees to buy 100 sprockets from `A` at €2/sprocket	`A`, `C`
other messages
`C` agrees to buy 100 sprockets from `A` at €2/sprocket	`A`, `C`

Hash	Pred	Block contents	Signed by
5195	none	`A` has 1000 sprockets available	`A`
5843	5195	`B` has 500 springs available	`B`
2874	5843	`A` looking for a supplier of 300 springs	`A`
9325	2874	`C` agrees to buy 100 sprockets from `A` at €2/sprocket	`A`, `C`

Hash	Pred	Block contents	Signed by
2547	none	`A` has 1000 sprockets available	`A`, `B`, `C`
8861	2547	`A` agrees to sell 800 sprockets to `B`	`A`

				5285	none	..	`A`
				7115	5285	..	`A`
1413	7115	..	`B`					5980	7115	..	`C`
6679	1413	..	`D`

Planet Haskell

April 17, 2021

April 15, 2021

Optics on functions

Profunctor optics

Lenses

Prisms

Traversals

Conclusion

April 14, 2021

Release management

Frontend

Profiling and Debugging

RTS

Compiler Performance

Runtime performance

Compiler correctness

Compiler functionality and language extensions

Compiler error messages refactoring

CI and infrastructure

April 13, 2021

Questions

Opening up Slack

Board officers

New Haskell Foundation website

What's an announcement? Where do minutes go? Where's transparency?!?

Get involved!

Polymorphic Variants

Implementation

Type definition

Elaboration and constraint generation

Creating variants

Pattern matching

Constraint solving

Equality TypeVariant TypeVariant

Equality TypeVariant TypePolyVariantLB

Equality TypeVariant TypePolyVariantUB

Equality TypePolyVariantLB TypePolyVariantLB

Equality TypePolyVariantLB TypePolyVariantUB

Equality TypePolyVariantUB TypePolyVariantUB (where the row type variables match)

Equality TypePolyVariantUB TypePolyVariantUB (where the row type variables don't match)

Instantiation

Substitution

Example

Elaboration and constraints generation

Constraint solving

First group

Second group

Result

Alternative approach: simulation in userland

Summary

April 12, 2021

April 10, 2021

Records

Row Polymorphism

Elaboration and constraint generation

Record literals

Record selection

Record extension

Pattern matching

Constraint solving

Two TypeRec

A TypeRec and a TypeRecExt

Two TypeRecExt

Instantiation

Substitution

Example

Elaboration

Constraint solving

First group

Second group

Third group

Result

Summary

April 09, 2021

April 08, 2021

Approach 1 - undefined

Approach 2A - Proxy

Approach 2B - proxy

Approach 3 - AllowAmbiguousTypes + TypeApplications

`Equality TypeVariant TypeVariant`

`Equality TypeVariant TypePolyVariantLB`

`Equality TypeVariant TypePolyVariantUB`

`Equality TypePolyVariantLB TypePolyVariantLB`

`Equality TypePolyVariantLB TypePolyVariantUB`

`Equality TypePolyVariantUB TypePolyVariantUB` (where the row type variables match)

`Equality TypePolyVariantUB TypePolyVariantUB` (where the row type variables don't match)

Approach 1 - `undefined`

Approach 2A - `Proxy`

Approach 2B - `proxy`

Approach 3 - `AllowAmbiguousTypes` + `TypeApplications`

`Equality t1 t2 (where t1 == t2)`

`Equality (TypeVar tv) t2`

`Equality (TypeApp f1 a1) (TypeApp f2 a2)`

`InstanceOf t1 t2`