add code sample

.gitignore

@@ -0,0 +1,20 @@
+dist
+dist-*
+cabal-dev
+*.o
+*.hi
+*.chi
+*.chs.h
+*.dyn_o
+*.dyn_hi
+.hpc
+.hsenv
+.cabal-sandbox/
+cabal.sandbox.config
+*.prof
+*.aux
+*.hp
+*.eventlog
+.stack-work/
+cabal.project.local
+.HTF/

code/ArgParser.hs

@@ -0,0 +1,47 @@
+module ArgParser where
+
+import Options.Applicative
+
+data HostMessage = HostMessage String Message
+
+data Message  =
+    Greet { hello :: String, quiet :: Bool }
+    | Farewell { bye :: String, quiet :: Bool }
+
+hostParser =  strOption
+    ( long "host"
+    <> metavar "HOST"
+    <> help "Who is the host" )
+
+quietParser =  switch
+    ( long "quiet"
+    <> help "Whether to be quiet" )
+
+greetParser :: Parser Message
+greetParser = Greet
+    <$> strOption
+        ( long "hello"
+        <> metavar "TARGET"
+        <> help "Target for the greeting" )
+    <*> quietParser
+
+farewellParser :: Parser Message
+farewellParser = Farewell
+    <$> strOption
+        ( long "bye"
+        <> metavar "TARGET"
+        <> help "Target for the farewell" )
+    <*> quietParser
+
+messageParser ::  Parser HostMessage
+messageParser = HostMessage <$> hostParser <*> (greetParser <|> farewellParser)
+
+main :: IO ()
+main = do
+    greet <- execParser $ info messageParser mempty
+    case greet of
+        HostMessage host (Greet hello False)
+            -> putStrLn $ "Hello, " ++ hello ++ ", from " ++ host
+        HostMessage host (Farewell bye False)
+            -> putStrLn $ "Bye, " ++ bye ++ ", from " ++ host
+        _                       -> return ()

code/Calculator.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+import Control.Monad.State.Strict
+import Control.Monad.Writer.Strict
+import Control.Monad.Trans
+import Control.Monad
+import Text.Read (readMaybe)
+
+calculator :: WriterT String (StateT Double IO) ()
+calculator = do
+    result <- get
+    liftIO $ print result
+    (op:input) <- liftIO getLine
+    let opFn = case op of
+            '+' -> sAdd
+            '-' -> sMinus
+            '*' -> sTime
+            '/' -> sDivide
+            _ -> const $ return ()
+    case readMaybe input of
+        Just x -> opFn x >> calculator
+        Nothing -> tell "Illegal input.\n"
+  where
+    sAdd x = do
+        tell $ "Add: " ++ (show x) ++ "\n"
+        modify (+ x)
+    sMinus x = do
+        tell $ "Minus: " ++ (show x) ++ "\n"
+        modify (\y -> y - x)
+    sTime x = do
+        tell $ "Time: " ++ (show x) ++ "\n"
+        modify (* x)
+    sDivide x = do
+        tell $ "Divide: " ++ (show x) ++ "\n"
+        modify (/ x)
+
+main :: IO ()
+main = (flip evalStateT) 0 $ do
+        log <- execWriterT calculator
+        liftIO $ do
+            putStr "Calculator log:\n"
+            putStr log

code/Database.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE EmptyDataDecls             #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE QuasiQuotes                #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE TypeFamilies               #-}
+
+import           Control.Monad.IO.Class  (liftIO)
+import           Control.Monad.Trans.Reader
+import           Database.Persist
+import           Database.Persist.Sqlite
+import           Database.Persist.TH
+import           Control.Monad.Logger
+import           Database.Esqueleto as E
+
+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
+Person
+    name String
+    age Int Maybe
+    deriving Show
+BlogPost
+    title String
+    authorId PersonId
+    deriving Show
+|]
+
+main :: IO ()
+main = runNoLoggingT . withSqlitePool "test.db" 10 . runSqlPool $ do
+    runMigration migrateAll
+
+    johnId <- insert $ Person "John" (Just 18)
+    johnId <- insert $ Person "Peter" (Just 20)
+    johnId <- insert $ Person "Mary" (Just 30)
+    johnId <- insert $ Person "Jane" (Just 14)
+
+    people <- E.select $ E.from $ \person -> return person
+    liftIO $ mapM_ (putStrLn . personName . entityVal) people
+
+    people <-
+        E.select $
+        E.from $ \p -> do
+        where_ (p E.^. PersonAge E.>. just (val 18))
+        return p
+
+    liftIO $ putStrLn "People older than 18 are:"
+    liftIO $ mapM_ (putStrLn . personName . entityVal) people

code/GuessNumber.hs

@@ -0,0 +1,51 @@
+module Main where
+
+import           Control.Monad.Trans.Class
+import           Control.Monad.Random
+import           Data.List
+import           System.Random
+
+type Perm = [Int]
+
+readInt :: IO Int
+readInt = getLine >>= return . read
+
+perms :: Int -> [Perm]
+perms n = go n [[]]
+  where
+    ns = [0..9]
+    go 0 ps = ps
+    go n ps = go (n - 1) [ x:p | x <- ns, p <- ps, x `notElem` p ]
+
+guess :: (RandomGen g) => [Perm] -> RandT g IO [Perm]
+guess xs
+    | length xs <= 1 = return xs
+    | otherwise = do
+        g <- uniform xs
+        (a, b)  <- lift $ do
+            putStrLn . concat $ map show g
+            putStrLn "A?"
+            a <- readInt
+            putStrLn "B?"
+            b <- readInt
+            return (a, b)
+
+        let allMark = mark xs g
+        let allZipped = filter (\z -> snd z == (a, b)) $ zip xs allMark
+        guess $ map fst allZipped
+
+mark :: [Perm] -> Perm -> [(Int, Int)]
+mark []     _ = []
+mark (x:xs) p = (markA x p, markB x p - markA x p) : mark xs p
+  where
+    markA x p = sum $ zipWith (\x y -> if x == y then 1 else 0) x p
+    markB x p = sum $ map (\x -> if x `elem` p then 1 else 0) x
+
+main = do
+    putStrLn "how many numebrs in a permutation(1~9)?"
+    n <- readInt
+    if n < 0 || n > 9
+        then putStrLn "well.."
+        else do
+            g <- getStdGen
+            evalRandT (guess (perms n) >>= lift . print) g

code/HList.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+
+module HList where
+
+
+data HList :: [*] -> * where
+    HNil  :: HList '[]
+    HCons :: x -> HList xs -> HList (x ': xs)
+
+class GetByType a xs where
+    getByType :: HList xs -> a
+
+instance {-# OVERLAPPING #-} GetByType a (a ': xs) where
+    getByType (HCons x _) = x
+
+instance GetByType a xs => GetByType a (b ': xs) where
+    getByType (HCons _ xs) = getByType xs
+
+
+main = do
+     let hlist = HCons (2 :: Int) $ HCons "hello" $ HCons True HNil
+     print (getByType hlist :: Int)
+     print (getByType hlist :: String)
+     print (getByType hlist :: Bool)

code/LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2016, winterland1989
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of winterland1989 nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

code/Lens.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE Rank2Types #-}
+
+module Lens where
+
+import Data.Functor.Identity  (Identity(..))
+import Control.Applicative    (Const(..))
+import Data.Function          ((&))
+
+--------------------------------------------------------------------------------
+
+over :: ((a -> Identity a) -> b -> Identity b) -> (a -> a) -> b -> b
+over lens f x = runIdentity $ lifted x
+  where
+    lifted = lens (Identity . f)
+
+set :: ((a -> Identity a) -> b -> Identity b) -> a -> b -> b
+set lens a' x = over lens (\_ -> a') x
+
+view :: ((a -> Const a a) -> b -> Const a b) -> b -> a
+view lens x = getConst ((lens Const) x)
+
+--------------------------------------------------------------------------------
+
+data Position = Position { positionX :: Double, positionY :: Double } deriving Show
+
+type Lens b a = forall f.Functor f => (a -> f a) -> b -> f b
+
+xLens :: Lens Position Double
+xLens f p = fmap (\x' -> setPositionX x' p) $ f (positionX p)
+  where
+    setPositionX :: Double -> Position -> Position
+    setPositionX x' p = p { positionX = x' }
+
+yLens :: Lens Position Double
+yLens f p = fmap (\y' -> p { positionY = y' }) $ f (positionY p)
+
+-- 中缀版本view
+(^.) :: b -> Lens b a -> a
+(^.) = flip view
+infixl 8 ^.
+
+-- 中缀版本over
+(%~) :: Lens b a -> (a -> a) -> b -> b
+(lens %~ f) x = over lens f x
+infixr 4 %~
+
+-- 中缀版本set
+(.~) :: Lens b a -> a -> b -> b
+(.~) = set
+infixr 4 .~
+
+main = do
+    let p = Position 123 456
+    putStrLn $ "orign value: " ++ show p
+    putStrLn $ "over xLens negate p:     " ++ show (over xLens negate p)
+    putStrLn $ "set xLens 0 p:           " ++ show (set xLens 0 p)
+    putStrLn $ "view yLens p:            " ++ show (view yLens p)
+    putStrLn $ "p & xLens %~ negate:     " ++ show (p & xLens %~ negate)
+    putStrLn $ "p & xLens .~ 0:          " ++ show (p & xLens .~ 0)
+    putStrLn $ "p ^. yLens:              " ++ show (p ^. yLens)