merge other branch

complexlens.hs

@@ -0,0 +1,53 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+
+import Control.Lens
+import Numeric.Lens
+import Data.Complex.Lens
+
+import Data.Complex
+import qualified Data.Map as Map
+
+l :: Num t => t
+l = view _1 (100, 200)
+-- [100,200,300]
+
+m :: (Num t) => (t, t, t)
+m = (100,200,200) & _3 %~ (+100)
+-- [100,200,300]
+
+n :: Num a => [a]
+n = [100,200,300] & traverse %~ (+1)
+-- [101,201,301]
+
+o :: Char
+o = "frodo" ^?! ix 3
+-- 'd'
+
+p :: Num a => [a]
+p = [[1,2,3], [4,5,6]] ^. traverse
+-- [1,2,3,4,5,6]
+
+q :: Num a => [a]
+q = [1,2,3,4,5] ^. _tail
+-- [2,3,4,5]
+
+r :: Maybe String
+r = Map.fromList [("foo", "bar")] ^.at "foo"
+-- "bar"
+
+s :: Integral a => Maybe a
+s = "1010110" ^? binary
+-- Just 86
+
+t :: RealFloat a => Complex a
+t = (mkPolar 1 pi/2) & _phase +~ pi
+
+u :: IO [String]
+u = ["first","second","third"] ^!! folded.act ((>> getLine) . putStrLn)
+-- first
+-- a
+-- second
+-- b
+-- third
+-- c
+-- ["a","b","c"]

conduit.hs

@@ -1,13 +1,27 @@
+{-# LANGUAGE MultiWayIf #-}
+
 import Data.Conduit
+import Control.Monad.Trans
 import qualified Data.Conduit.List as CL
 
 source :: Source IO Int
-source = CL.sourceList [1..25]
+source = CL.sourceList [1..100]
 
 conduit :: Conduit Int IO String
-conduit = CL.map show
+conduit = do
+  val <- await
+  liftIO $ print val
+  case val of
+    Nothing -> return ()
+    Just n -> do
+      if | n `mod` 15 == 0 -> yield "FizzBuzz"
+         | n `mod` 5  == 0 -> yield "Fizz"
+         | n `mod` 3  == 0 -> yield "Buzz"
+         | otherwise       -> return ()
+      conduit
 
 sink :: Sink String IO ()
 sink = CL.mapM_ putStrLn
 
+main :: IO ()
 main = source $$ conduit =$ sink

constraintkinds.hs

@@ -0,0 +1,19 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ConstraintKinds #-}
+
+import GHC.Exts (Constraint)
+import Data.Hashable
+import Data.HashSet
+
+type family Con a :: Constraint
+type instance Con [a] = (Ord a, Eq a)
+type instance Con (HashSet a) = (Hashable a)
+
+class Sized a where
+  gsize :: Con a => a -> Int
+
+instance Sized [a] where
+  gsize = length
+
+instance Sized (HashSet a) where
+  gsize = size

data.hs

@@ -33,4 +33,4 @@ example3 = over [Val 1, Val 2, Val 3]
 
 example4 :: (Val, Val, Val)
 example4 = over (Val 1, Val 2, Val 3)
--- [Val 100,Val 200,Val 300]
+-- (Val 100,Val 200,Val 300)

datafamily.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE TypeFamilies #-}
+
+import qualified Data.Vector.Unboxed as V
+
+data family Array a
+data instance Array Int       = IArray (V.Vector Int)
+data instance Array Bool      = BArray (V.Vector Bool)
+data instance Array (a,b)     = PArray (Array a) (Array b)
+data instance Array (Maybe a) = MArray (V.Vector Bool) (Array a)
+
+class IArray a where
+  index :: Array a -> Int -> a
+
+instance IArray Int where
+  index (IArray xs) i = xs V.! i
+
+instance IArray Bool where
+  index (BArray xs) i = xs V.! i
+
+-- Vector of pairs
+instance (IArray a, IArray b) => IArray (a, b) where
+  index (PArray xs ys) i = (index xs i, index ys i)
+
+-- Vector of missing values
+instance (IArray a) => IArray (Maybe a) where
+  index (MArray bm xs) i =
+    case bm V.! i of
+      True  -> Nothing
+      False -> Just $ index xs i

datakinds.hs

@@ -0,0 +1,58 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+data Nat = Z | S Nat deriving (Eq, Show)
+
+type Zero  = Z
+type One   = S Zero
+type Two   = S One
+type Three = S Two
+type Four  = S Three
+type Five  = S Four
+
+data Vec :: Nat -> * -> * where
+  Nil :: Vec Z a
+  Cons :: a -> Vec n a -> Vec (S n) a
+
+instance Show (Vec Z a) where
+  show Nil = "'[]"
+
+instance (Show a, Show (Vec n a)) => Show (Vec (S n) a) where
+  show (Cons x xs) = show x ++ "'::" ++ show xs
+
+class FromList n where
+  fromList :: [a] -> Vec n a
+
+instance FromList Z where
+  fromList [] = Nil
+
+instance FromList n => FromList (S n) where
+  fromList (x:xs) = Cons x $ fromList xs
+
+
+lengthVec :: Vec n a -> Nat
+lengthVec Nil = Z
+lengthVec (Cons x xs) = S (lengthVec xs)
+
+zipVec :: Vec n a -> Vec n b -> Vec n (a,b)
+zipVec Nil Nil = Nil
+zipVec (Cons x xs) (Cons y ys) = Cons (x,y) (zipVec xs ys)
+
+
+vec4 :: Vec Four Int
+vec4 = fromList [0, 1, 2, 3]
+
+vec5 :: Vec Five Int
+vec5 = fromList [0, 1, 2, 3, 4]
+
+
+example1 :: Nat
+example1 = lengthVec vec4
+-- S (S (S (S Z)))
+
+example2 :: Vec Four (Int, Int)
+example2 = zipVec vec4 vec4
+-- (0,0)':(1,1)':(2,2)':(3,3)':'[]

dict.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE KindSignatures #-}
+
+import GHC.Exts (Constraint)
+
+data Dict :: Constraint -> * where
+  Dict :: (c) => Dict c
+
+dShow :: Dict (Show a) -> a -> String
+dShow Dict x = show x
+
+dEqNum :: Dict (Eq a, Num a) -> a -> Bool
+dEqNum Dict x = x == 0
+
+
+fShow :: String
+fShow = dShow Dict 10
+
+fEqual :: Bool
+fEqual = dEqNum Dict 0

either.hs

@@ -1,6 +1,6 @@
 sdiv :: Double -> Double -> Either String Double
 sdiv _ 0 = throwError "divide by zero"
-sdiv i j = Right $ i / j
+sdiv i j = return $ i / j
 
 example :: Double -> Double -> Either String Double
 example n m = do

eithert.hs

@@ -9,8 +9,8 @@ data Failure
 main :: IO ()
 main = do
   e <- runEitherT $ do
-      lift $ putStrLn "Enter a positive number."
-      s <- lift getLine
+      liftIO $ putStrLn "Enter a positive number."
+      s <- liftIO getLine
       n <- tryRead (ReadError s) s
       if n > 0
         then return $ n + 1

equal.hs

@@ -0,0 +1,16 @@
+{-# LANGUAGE GADTs #-}
+
+data Eql a b where
+  Refl :: Eql a a
+
+sym :: Eql a b -> Eql b a
+sym Refl = Refl
+
+cong :: Eql a b -> Eql (f a) (f b)
+cong Refl = Refl
+
+trans :: Eql a b -> Eql b c -> Eql a c
+trans Refl Refl = Refl
+
+cast :: Eql a b -> a -> b
+cast Refl = id

errors.hs

@@ -9,16 +9,19 @@ data Exception
 instance Error Exception where
   noMsg = GenericFailure
 
-type FailMonad a = ErrorT Exception Identity a
+type ErrMonad a = ErrorT Exception Identity a
 
-example :: Int -> Int -> FailMonad Int
+example :: Int -> Int -> ErrMonad Int
 example x y = do
   case y of
-    0 -> throwError $ Failure "it didn't work!"
+    0 -> throwError $ Failure "division by zero"
     x -> return $ x `div` y
 
-runFail :: FailMonad a -> Either Exception a
+runFail :: ErrMonad a -> Either Exception a
 runFail = runIdentity . runErrorT
 
+example1 :: Either Exception Int
 example1 = runFail $ example 2 3
+
+example2 :: Either Exception Int
 example2 = runFail $ example 2 0

family_nat.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE TypeOperators #-}
+
+data Z
+data S n
+
+data Nat n where
+  Zero :: Nat Z
+  Succ :: Nat n -> Nat (S n)
+
+data Eql a b where
+  Refl :: Eql a a
+
+type family Add m n
+type instance Add Z n = n
+type instance Add (S m) n = S (Add m n)
+
+type family Pred n
+type instance Pred Z = Z
+type instance Pred (S n) = n
+
+add :: Nat n -> Nat m -> Nat (Add n m)
+add Zero     m = m
+add (Succ n) m = Succ (add n m)
+
+cong :: Eql a b -> Eql (f a) (f b)
+cong Refl = Refl
+
+plus_zero :: forall n. Nat n -> Eql (Add n Z) n
+plus_zero Zero = Refl
+plus_zero (Succ n) = cong (plus_zero n)

family_nat_operators.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+
+data Z
+data S n
+
+data Nat n where
+  Zero :: Nat Z
+  Succ :: Nat n -> Nat (S n)
+
+data a :=: b where
+  Refl :: a :=: a
+
+type family Add m n
+type instance Add Z n = n
+type instance Add (S m) n = S (Add m n)
+
+type family Pred n
+type instance Pred Z = Z
+type instance Pred (S n) = n
+
+add :: Nat n -> Nat m -> Nat (Add n m)
+add Zero     m = m
+add (Succ n) m = Succ (add n m)
+
+cong :: a :=: b -> (f a) :=: (f b)
+cong Refl = Refl
+
+plus_zero :: forall n. Nat n -> (Add n Z) :=: n
+plus_zero Zero = Refl
+plus_zero (Succ n) = cong (plus_zero n)
+
+type family m :+ n :: *
+type instance Z :+ n = n
+type instance (S m) :+ n = S (m :+ n)
+
+-- m+1+n = 1+m+n
+assoc :: forall m n. Nat m -> Nat n -> (m :+ (S Z) :+ n) :=: (S Z :+ m :+ n)
+assoc Zero n = Refl
+assoc (Succ m) n = cong (assoc m n)

family_type.hs

@@ -0,0 +1,16 @@
+{-# LANGUAGE TypeFamilies #-}
+
+import Data.Char
+
+type family Rep a :: *
+type instance Rep Int  = Char
+type instance Rep Char = Int
+
+class Convertible a where
+  convert :: a -> Rep a
+
+instance Convertible Int where
+  convert = chr
+
+instance Convertible Char where
+  convert = ord

fext.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+
+class Expr repr where
+  lit :: Int -> repr
+  neg :: repr -> repr
+  add :: repr -> repr -> repr
+  mul :: repr -> repr -> repr
+
+instance Expr Int where
+  lit n = n
+  neg a = -a
+  add a b = a + b
+  mul a b = a * b
+
+instance Expr String where
+  lit n = show n
+  neg a = "(-" ++ a ++ ")"
+  add a b = "(" ++ a ++ " + " ++ b ++ ")"
+  mul a b = "(" ++ a ++ " * " ++ b ++ ")"
+
+class BoolExpr repr where
+  eq :: repr -> repr -> repr
+  tr :: repr
+  fl :: repr
+
+instance BoolExpr Int where
+  eq a b = if a == b then tr else fl
+  tr = 1
+  fl = 0
+
+instance BoolExpr String where
+  eq a b = "(" ++ a ++ " == " ++ b ++ ")"
+  tr = "true"
+  fl = "false"
+
+eval :: Int -> Int
+eval = id
+
+render :: String -> String
+render = id
+
+expr :: (BoolExpr repr, Expr repr) => repr
+expr = eq (add (lit 1) (lit 2)) (lit 3)
+
+result :: Int
+result = eval expr
+-- 1
+
+string :: String
+string = render expr
+-- "((1 + 2) == 3)"

ffi.hs

@@ -1,9 +1,9 @@
 -- ghc qsort.o ffi.hs -o ffi
-
 {-# LANGUAGE ForeignFunctionInterface #-}
 
 import Foreign.Ptr
 import Foreign.C.Types
+import Foreign.ForeignPtr
 import Foreign.ForeignPtr.Unsafe
 
 import qualified Data.Vector.Storable as V
@@ -12,14 +12,14 @@ import qualified Data.Vector.Storable.Mutable as VM
 foreign import ccall safe "sort" qsort
     :: Ptr a -> CInt -> CInt -> IO ()
 
-
-vecPtr :: VM.Storable a => VM.MVector s a -> Ptr a
-vecPtr = unsafeForeignPtrToPtr . fst . VM.unsafeToForeignPtr0
+vecPtr :: VM.MVector s CInt -> ForeignPtr CInt
+vecPtr = fst . VM.unsafeToForeignPtr0
 
 main :: IO ()
 main = do
-  let vs  = V.fromList ([1,3,5,2,1,2,5,9,6] :: [CInt])
+  let vs = V.fromList ([1,3,5,2,1,2,5,9,6] :: [CInt])
   v <- V.thaw vs
-  qsort (vecPtr v) 0 9
+  withForeignPtr (vecPtr v) $ \ptr -> do
+    qsort ptr 0 9
   out <- V.freeze v
   print out

final.hs

@@ -1,18 +1,11 @@
-type Arr exp a b = exp a -> exp b
+{-# LANGUAGE NoMonomorphismRestriction #-}
 
-class Expr exp where
-  lam :: (exp a -> exp b) -> exp (Arr exp a b)
-  app :: exp (Arr exp a b) -> exp a -> exp b
-  lit :: a -> exp a
+import Prelude hiding (id)
 
-id :: Expr rep => rep (a -> a)
-id = (lam (\x -> x))
-
-tr ::  Expr rep => rep (a -> b -> a)
-tr = lam (\x -> lam (\y -> x))
-
-fl ::  Expr rep => rep (a -> b -> b)
-fl = lam (\x -> lam (\y -> x))
+class Expr rep where
+  lam :: (rep a -> rep b) -> rep (a -> b)
+  app :: rep (a -> b) -> (rep a -> rep b)
+  lit :: a -> rep a
 
 newtype Interpret a = R { reify :: a }
 
@@ -20,3 +13,21 @@ instance Expr Interpret where
   lam f   = R $ reify . f . R
   app f a = R $ reify f $ reify a
   lit     = R
+
+eval :: Interpret a -> a
+eval e = reify e
+
+
+e1 :: Expr rep => rep Int
+e1 = app (lam (\x -> x)) (lit 3)
+
+e2 :: Expr rep => rep Int
+e2 = app (lam (\x -> lit 4)) (lam $ \x -> lam $ \y -> y)
+
+example1 :: Int
+example1 = eval e1
+-- 3
+
+example2 :: Int
+example2 = eval e2
+-- 4

foldable_traversable.hs

@@ -3,8 +3,10 @@ import Data.Foldable
 import Data.Traversable
 
 import Control.Applicative
+import Control.Monad.Identity (runIdentity)
 import Prelude hiding (mapM_, foldr)
 
+-- Rose Tree
 data Tree a = Node a [Tree a] deriving (Show)
 
 instance Functor Tree where
@@ -16,9 +18,11 @@ instance Traversable Tree where
 instance Foldable Tree where
   foldMap f (Node x ts) = f x `mappend` foldMap (foldMap f) ts
 
+
 tree :: Tree Integer
 tree = Node 1 [Node 1 [], Node 2 [] ,Node 3 []]
 
+
 example1 :: IO ()
 example1 = mapM_ print tree
 
@@ -27,3 +31,6 @@ example2 = foldr (+) 0 tree
 
 example3 :: Maybe (Tree Integer)
 example3 = traverse (\x -> if x > 2 then Just x else Nothing) tree
+
+example4 :: Tree Integer
+example4 = runIdentity $ traverse (\x -> pure (x+1)) tree

fundeps.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+data Z
+data S n
+
+type Zero  = Z
+type One   = S Zero
+type Two   = S One
+type Three = S Two
+type Four  = S Three
+
+zero :: Zero
+zero = undefined
+
+one :: One
+one = undefined
+
+two :: Two
+two = undefined
+
+three :: Three
+three = undefined
+
+four :: Four
+four = undefined
+
+class Eval a where
+  eval :: a -> Int
+
+instance Eval Zero where
+  eval _ = 0
+
+instance Eval n => Eval (S n) where
+  eval m = 1 + eval (prev m)
+
+class Pred a b | a -> b where
+  prev :: a -> b
+
+instance Pred Zero Zero where
+  prev = undefined
+
+instance Pred (S n) n where
+  prev = undefined
+
+class Add a b c | a b -> c where
+  add :: a -> b -> c
+
+instance Add Zero a a where
+  add = undefined
+
+instance Add a b c => Add (S a) b (S c) where
+  add = undefined
+
+f :: Three
+f = add one two
+
+g :: S (S (S (S Z)))
+g = add two two
+
+h :: Int
+h = eval (add three four)

gadt.hs

@@ -7,10 +7,10 @@ data Term a where
   If     :: Term Bool -> Term a -> Term a -> Term a
 
 eval :: Term a -> a
-eval (Lit i)      = i
-eval (Succ t)     = 1 + eval t                          -- Here ( a ~ Term Int)
-eval (IsZero i)   = eval i == 0                         -- Here ( a ~ Term Int)
-eval (If b e1 e2) = if eval b then eval e1 else eval e2
+eval (Lit i)      = i                                   -- Term a
+eval (Succ t)     = 1 + eval t                          -- Term (a ~ Int)
+eval (IsZero i)   = eval i == 0                         -- Term (a ~ Int)
+eval (If b e1 e2) = if eval b then eval e1 else eval e2 -- Term (a ~ Bool)
 
 example :: Int
 example = eval (Succ (Succ (Lit 3)))

generics.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+
+import GHC.Generics
+
+data Animal
+  = Dog
+  | Cat
+
+instance Generic Animal where
+  type Rep Animal = D1 T_Animal ((C1 C_Dog U1) :+: (C1 C_Cat U1))
+
+  from Dog = M1 (L1 (M1 U1))
+  from Cat = M1 (R1 (M1 U1))
+
+  to (M1 (L1 (M1 U1))) = Dog
+  to (M1 (R1 (M1 U1))) = Cat
+
+data T_Animal
+data C_Dog
+data C_Cat
+
+instance Datatype T_Animal where
+  datatypeName _ = "Animal"
+  moduleName _ = "Main"
+
+instance Constructor C_Dog where
+  conName _ = "Dog"
+
+instance Constructor C_Cat where
+  conName _ = "Cat"

hlist.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE KindSignatures #-}
+
+infixr 5 :::
+
+data HList (ts :: [ * ]) where
+  Nil :: HList '[]
+  (:::) :: t -> HList ts -> HList (t ': ts)
+
+-- Take the head of a non-empty list with the first value as Bool type.
+headBool :: HList (Bool ': xs) -> Bool
+headBool hlist = case hlist of
+  (a ::: _) -> a
+
+hlength :: HList x -> Int
+hlength Nil = 0
+hlength (_ ::: b) = 1 + (hlength b)
+
+
+example1 :: (Bool, (String, (Double, ())))
+example1 = (True, ("foo", (3.14, ())))
+
+example2 :: HList '[Bool, String , Double , ()]
+example2 = True ::: "foo" ::: 3.14 ::: () ::: Nil

hoas.hs

@@ -5,11 +5,6 @@ data Expr a where
   Lam :: (Expr a -> Expr b) -> Expr (a -> b)
   App :: Expr (a -> b) -> Expr a -> Expr b
 
-eval :: Expr a -> a
-eval (Con v) = v
-eval (Lam f) = \x -> eval (f (Con x))
-eval (App e1 e2) = (eval e1) (eval e2)
-
 id :: Expr (a -> a)
 id = Lam (\x -> x)
 
@@ -18,3 +13,8 @@ tr = Lam (\x -> (Lam (\y -> x)))
 
 fl :: Expr (a -> b -> b)
 fl = Lam (\x -> (Lam (\y -> y)))
+
+eval :: Expr a -> a
+eval (Con v) = v
+eval (Lam f) = \x -> eval (f (Con x))
+eval (App e1 e2) = (eval e1) (eval e2)

initial.hs

@@ -0,0 +1,80 @@
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+type Algebra f a = f a -> a
+type Coalgebra f a = a -> f a
+
+newtype Fix f = Fix { unFix :: f (Fix f) }
+
+cata :: Functor f => Algebra f a -> Fix f -> a
+cata alg = alg . fmap (cata alg) . unFix
+
+ana :: Functor f => Coalgebra f a -> a -> Fix f
+ana coalg = Fix . fmap (ana coalg) . coalg
+
+hylo :: Functor f => Algebra f b -> Coalgebra f a -> a -> b
+hylo f g = cata f . ana g
+
+type Nat = Fix NatF
+data NatF a = S a | Z deriving (Eq,Show)
+
+instance Functor NatF where
+  fmap f Z     = Z
+  fmap f (S x) = S (f x)
+
+plus :: Nat -> Nat -> Nat
+plus n = cata phi where
+  phi Z     = n
+  phi (S m) = s m
+
+times :: Nat -> Nat -> Nat
+times n = cata phi where
+  phi Z     = z
+  phi (S m) = plus n m
+
+int :: Nat -> Int
+int = cata phi where
+  phi  Z    = 0
+  phi (S f) = 1 + f
+
+nat :: Integer -> Nat
+nat = ana (psi Z S) where
+  psi f _ 0 = f
+  psi _ f n = f (n-1)
+
+z :: Nat
+z = Fix Z
+
+s :: Nat -> Nat
+s = Fix . S
+
+
+type Str = Fix StrF
+data StrF x = Cons Char x | Nil
+
+instance Functor StrF where
+  fmap f (Cons a as) = Cons a (f as)
+  fmap f Nil = Nil
+
+nil :: Str
+nil = Fix Nil
+
+cons :: Char -> Str -> Str
+cons x xs = Fix (Cons x xs)
+
+str :: Str -> String
+str = cata phi where
+  phi Nil         = []
+  phi (Cons x xs) = x : xs
+
+str' :: String -> Str
+str' = ana (psi Nil Cons) where
+  psi f _ [] = f
+  psi _ f (a:as) = f a as
+
+example1 :: Int
+example1 = int (plus (nat 125) (nat 25))
+-- 150

initial_interpreter.hs

@@ -0,0 +1,62 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+import Control.Applicative
+import qualified Data.Map as M
+
+type Algebra f a = f a -> a
+type Coalgebra f a = a -> f a
+
+newtype Fix f = Fix { unFix :: f (Fix f) }
+
+cata :: Functor f => Algebra f a -> Fix f -> a
+cata alg = alg . fmap (cata alg) . unFix
+
+ana :: Functor f => Coalgebra f a -> a -> Fix f
+ana coalg = Fix . fmap (ana coalg) . coalg
+
+hylo :: Functor f => Algebra f b -> Coalgebra f a -> a -> b
+hylo f g = cata f . ana g
+
+type Id = String
+type Env = M.Map Id Int
+
+type Expr = Fix ExprF
+data ExprF a
+  = Lit Int
+  | Var Id
+  | Add a a
+  | Mul a a
+  deriving (Show, Eq, Ord, Functor)
+
+deriving instance Eq (f (Fix f)) => Eq (Fix f)
+deriving instance Ord (f (Fix f)) => Ord (Fix f)
+deriving instance Show (f (Fix f)) => Show (Fix f)
+
+eval :: M.Map Id Int -> Fix ExprF -> Maybe Int
+eval env = cata phi where
+  phi ex = case ex of
+    Lit c   -> pure c
+    Var i   -> M.lookup i env
+    Add x y -> liftA2 (+) x y
+    Mul x y -> liftA2 (*) x y
+
+expr :: Expr
+expr = Fix (Mul n (Fix (Add x y)))
+  where
+    n = Fix (Lit 10)
+    x = Fix (Var "x")
+    y = Fix (Var "y")
+
+env :: M.Map Id Int
+env = M.fromList [("x", 1), ("y", 2)]
+
+compose :: (f (Fix f) -> c) -> (a -> Fix f) -> a -> c
+compose x y = x . unFix . y
+
+example :: Maybe Int
+example = eval env expr
+-- Just 30

kindpoly.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+
+data Proxy a = Proxy
+data Rep = Rep
+
+class PolyClass a where
+  foo :: Proxy a -> Rep
+  foo = const Rep
+
+-- () :: *
+-- [] :: * -> *
+-- Either :: * -> * -> *
+
+instance PolyClass ()
+instance PolyClass []
+instance PolyClass Either

kindsignatures.hs

@@ -0,0 +1,15 @@
+{-# Language GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+
+data Term a :: * where
+  Lit    :: a -> Term a
+  Succ   :: Term Int -> Term Int
+  IsZero :: Term Int -> Term Bool
+  If     :: Term Bool -> Term a -> Term a -> Term a
+
+data Vec :: * -> * -> * where
+  Nil :: Vec n a
+  Cons :: a -> Vec n a -> Vec n a
+
+data Fix :: (* -> *) -> * where
+  In :: f (Fix f) -> Fix f

lens_aeson.hs

@@ -6,6 +6,7 @@ import Data.Aeson.Lens
 import Data.Aeson (decode, Value)
 import Data.ByteString.Lazy as BL
 
+main :: IO ()
 main = do
   contents <- BL.readFile "kiva.json"
   let Just json = decode contents :: Maybe Value

mparam.hs

@@ -0,0 +1,15 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+import Data.Char
+
+class Convertible a b where
+  convert :: a -> b
+
+instance Convertible Int Integer where
+  convert = toInteger
+
+instance Convertible Int Char where
+  convert = chr
+
+instance Convertible Char Int where
+  convert = ord

mparam_fun.hs

@@ -0,0 +1,14 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+
+
+import Data.Char
+
+class Convertible a b | a -> b where
+  convert :: a -> b
+
+instance Convertible Int Char where
+  convert = chr
+
+instance Convertible Char Int where
+  convert = ord

newtype.hs

@@ -0,0 +1,12 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+newtype Velocity = Velocity { unVelocity :: Double }
+  deriving (Eq, Ord)
+
+v :: Velocity
+v = Velocity 2.718
+
+x :: Double
+x = 6.636
+
+err = v + x

nonempty.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+data Size = None | Many
+
+data List a b where
+  Nil  :: List None a
+  Cons :: a -> List b a -> List Many a
+
+head' :: List Many a -> a
+head' (Cons x _) = x
+
+example1 :: Int
+example1 = head' (1 `Cons` (2 `Cons` Nil))

optparse_applicative.hs

@@ -0,0 +1,48 @@
+import Data.List
+import Data.Monoid
+import Options.Applicative
+
+data Opts = Opts
+  { _files :: [String]
+  , _quiet :: Bool
+  , _fast :: Speed
+  }
+
+data Speed = Slow | Fast
+
+options :: Parser Opts
+options = Opts <$> filename <*> quiet <*> fast
+  where
+    filename :: Parser [String]
+    filename = many $ argument str $
+         metavar "filename..."
+      <> help "Input files"
+
+    fast :: Parser Speed
+    fast = flag Slow Fast $
+         long "cheetah"
+      <> help "Perform task quickly."
+
+    quiet :: Parser Bool
+    quiet = switch $
+         long "quiet"
+      <> help "Whether to shut up."
+
+greet :: Opts -> IO ()
+greet (Opts files quiet fast) = do
+  putStrLn "reading these files:"
+  mapM_ print files
+
+  case fast of
+    Fast -> putStrLn "quickly"
+    Slow -> putStrLn "slowly"
+
+  case quiet of
+    True  -> putStrLn "quietly"
+    False -> putStrLn "loudly"
+
+opts :: ParserInfo Opts
+opts = info (helper <*> options) fullDesc
+
+main :: IO ()
+main = execParser opts >>= greet

parsec_operators.hs

@@ -233,4 +233,3 @@ main = do
   case res of
     Left err -> print err
     Right ast -> mapM_ print ast
-  return ()

parser.hs

@@ -14,7 +14,7 @@ data Expr
   | App Expr Expr
   | Var Id
   | Num Int
-  | Op Binop Expr Expr
+  | Op  Binop Expr Expr
   deriving (Show)
 
 data Binop = Add | Sub | Mul deriving Show

pipes.hs

@@ -16,4 +16,4 @@ c = forever $ do
     then yield x
     else return ()
 
-contrived = toList $ a >-> b >-> c
+result = toList $ a >-> b >-> c

qsort.c

@@ -1,5 +1,4 @@
 /* $(CC) -c qsort.c -o qsort.o */
-
 void swap(int *a, int *b)
 {
     int t = *a;
@@ -7,21 +6,21 @@ void swap(int *a, int *b)
     *b = t;
 }
 
-void sort(int *arr, int beg, int end)
+void sort(int *xs, int beg, int end)
 {
     if (end > beg + 1) {
-        int piv = arr[beg], l = beg + 1, r = end;
+        int piv = xs[beg], l = beg + 1, r = end;
 
         while (l < r) {
-            if (arr[l] <= piv) {
+            if (xs[l] <= piv) {
                 l++;
             } else {
-                swap(&arr[l], &arr[--r]);
+                swap(&xs[l], &xs[--r]);
             }
         }
 
-        swap(&arr[--l], &arr[beg]);
-        sort(arr, beg, l);
-        sort(arr, r, end);
+        swap(&xs[--l], &xs[beg]);
+        sort(xs, beg, l);
+        sort(xs, r, end);
     }
 }

random.hs

@@ -1,17 +0,0 @@
-import System.Random
-
-data Cat = Cat String deriving Show
-
-data State a = Live a | Dead a deriving Show
-
-decayed :: StdGen -> Bool
-decayed gen = fst $ random gen
-
-box :: StdGen -> Cat -> State Cat
-box gen x = if decayed gen then Live x else Dead x
-
-main :: IO ()
-main = do
-  gen <- getStdGen
-  let cat = Cat "Fluffy"
-  print $ box gen cat

reader.hs

@@ -9,12 +9,12 @@ computation :: Reader MyState (Maybe String)
 computation = do
   n <- asks bar
   x <- asks foo
-  if n > 0 then
-    return (Just x)
-  else
-    return Nothing
+  if n > 0
+    then return (Just x)
+    else return Nothing
 
+example1 :: Maybe String
 example1 = runReader computation $ MyState "hello!" 1
-example2 = runReader computation $ MyState "example!" 0
 
-main = return ()
+example2 :: Maybe String
+example2 = runReader computation $ MyState "example!" 0

reader_impl.hs

@@ -12,5 +12,3 @@ asks f = Reader f
 
 local :: (r -> b) -> Reader b a -> Reader r a
 local f m = Reader $ runReader m . f
-
-main = return ()

safe.hs

@@ -0,0 +1,10 @@
+{-# LANGUAGE Safe #-}
+
+import Unsafe.Coerce
+import System.IO.Unsafe
+
+sin :: String
+sin = unsafePerformIO $ getLine
+
+mortalsin :: a
+mortalsin = unsafeCoerce 3.14 ()

scotty.hs

@@ -3,7 +3,7 @@
 import Web.Scotty
 
 import qualified Text.Blaze.Html5 as H
-import Text.Blaze.Html5 hiding (html, param)
+import Text.Blaze.Html5 (toHtml, Html)
 import Text.Blaze.Html.Renderer.Text (renderHtml)
 
 greet :: String -> Html
@@ -14,11 +14,13 @@ greet user = H.html $ do
     H.h1 "Greetings!"
     H.p ("Hello " >> toHtml user >> "!")
 
-main :: IO ()
-main = scotty 8000 $ do
+app = do
   get "/" $
     text "Home Page"
 
   get "/greet/:name" $ do
     name <- param "name"
     html $ renderHtml (greet name)
+
+main :: IO ()
+main = scotty 8000 app

sequence.hs

@@ -0,0 +1,12 @@
+import Data.Sequence
+
+a :: Seq Int
+a = fromList [1,2,3]
+
+a0 :: Seq Int
+a0 = a |> 4
+-- [1,2,3,4]
+
+a1 :: Seq Int
+a1 = 0 <| a
+-- [0,1,2,3]

simple_ffi.hs

@@ -1,5 +1,4 @@
 -- ghc simple.o simple_ffi.hs -o simple_ffi
-
 {-# LANGUAGE ForeignFunctionInterface #-}
 
 import Foreign.C.Types

simplelens.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+import Control.Lens
+
+data Rec = MkRec { _foo :: Int , _bar :: Int } deriving Show
+makeLenses ''Rec
+
+x :: Rec
+x = MkRec { _foo = 1024, _bar = 1024 }
+
+get1 :: Int
+get1 = (_foo x) + (_bar x)
+
+get2 :: Int
+get2 = (x ^. foo) + (x ^. bar)
+
+get3 :: Int
+get3 = (view foo x) + (view bar x)
+
+
+set1 :: Rec
+set1 = x { _foo = 1, _bar = 2 }
+
+set2 :: Rec
+set2 = x & (foo .~ 1) . (bar .~ 2)
+
+set3 :: Rec
+set3 = x & (set foo 1) . (set bar 2)

smallcheck.hs

@@ -1,7 +1,7 @@
 import Test.SmallCheck
 
 distrib :: Int -> Int -> Int -> Bool
-distrib a b c = a * (b + c) == a * b + a *c
+distrib a b c = a * (b + c) == a * b + a * c
 
 cauchy :: [Double] -> [Double] -> Bool
 cauchy xs ys = (abs (dot xs ys))^2 <= (dot xs xs) * (dot ys ys)
@@ -17,8 +17,8 @@ main = do
   putStrLn "Testing distributivity..."
   smallCheck 25 distrib
 
-  putStrLn "Testing Cauchy-Swartz..."
+  putStrLn "Testing Cauchy-Schwarz..."
   smallCheck 4 cauchy
 
-  putStrLn "Testing invalid Cauchy-Swartz..."
+  putStrLn "Testing invalid Cauchy-Schwarz..."
   smallCheck 4 failure

typeable.hs

@@ -17,7 +17,7 @@ example2 = typeOf (Zoo [Cat, Dog])
 -- Zoo Animal
 
 example3 :: TypeRep
-example3 = typeOf ((1, 3.14, "foo") :: (Int, Double, String))
+example3 = typeOf ((1, 6.636e-34, "foo") :: (Int, Double, String))
 -- (Int,Double,[Char])
 
 example4 :: Bool

typenat.hs

@@ -0,0 +1,13 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE TypeOperators #-}
+
+import GHC.TypeLits
+
+data Vec :: Nat -> * -> * where
+  Nil :: Vec 0 a
+  Cons :: a -> Vec n a -> Vec (1 + n) a
+
+vec3 :: Vec (1 + (1 + (1 + 0))) Int
+vec3 = 0 `Cons` (1 `Cons` (2 `Cons` Nil))

uniplate.hs

@@ -6,7 +6,7 @@ data Expr a
   | Var a
   | Not (Expr a)
   | And (Expr a) (Expr a)
-  | Or (Expr a) (Expr a)
+  | Or  (Expr a) (Expr a)
   deriving (Show, Eq)
 
 instance Uniplate (Expr a) where

vector_mutable.hs

@@ -6,8 +6,8 @@ import Data.Vector.Unboxed.Mutable
 example :: IO (MVector RealWorld Int)
 example = do
   v <- new 10
-  forM [0..9] $ \i ->
-     write v i i
+  forM_ [0..9] $ \i ->
+     write v i (2*i)
   return v
 
 main :: IO ()