├── C16 ├── KindPoly.hs ├── id.hs ├── MR.hs ├── MR2.hs ├── RecordFields.hs ├── FunDep.hs ├── InjectiveTypeFamiliesTest.hs ├── TypeFamily3.hs ├── Person.hs ├── TypeFamily2.hs ├── TypeComputation1.hs ├── Test.hs ├── Rank.hs ├── TypeFamily.hs ├── ImplicitParams.hs ├── GEq.hs ├── RuntimeRep.hs ├── InstanceMatchTest.hs ├── DependentType.hs ├── MyShow.hs ├── Dynamic.hs ├── fact.hs ├── SplitClasses.hs └── TypeComputation2.hs ├── C01 └── Helloworld.hs ├── C18 ├── person.json ├── TestZipN2.hs ├── ZipNTest.hs ├── TypeArityTest.hs ├── ExprQuoteTest.hs ├── Lenses.hs ├── PersonValueProviderTest.hs ├── Lift.hs ├── StandaloneDeriveTest.hs ├── PersonValueProvider.hs ├── aeson.hs ├── TypeArity.hs ├── ZipN.hs ├── ExprQuote.hs ├── Person.hs ├── ZipN2.hs └── DeriveTopdown.hs ├── C20 ├── ModuleCheck.hs ├── TestAll.hs ├── UnitTest.hs ├── QuickCheck1.hs ├── QuickCheck.hs ├── SmallCheck.hs └── QuickCheckGen.hs ├── C22 ├── myhaskell │ ├── Setup.hs │ ├── LICENSE │ └── myhaskell.cabal ├── Stack1.hs ├── Fib.o ├── Fib.exe ├── Fib.hs └── Fib.prof ├── README.md ├── C11 ├── Dict │ ├── longman.idx │ └── longman.ifo ├── name.hs ├── foreverName.hs ├── argsTest.hs ├── bool.hs ├── SystemProcess.hs ├── UnsafeIOTest.hs ├── printf.hs └── Main.hs ├── C17 ├── GeneratedGenericClassInstances.hs ├── GenericByteString.hs ├── FunctorGeneric.hs ├── SYB1.hs ├── SYBBinary.hs ├── GenericShow.hs ├── Generic1.hs └── Generic0.hs ├── C06 ├── ListComp.hs ├── transpose.hs ├── Permutations.hs ├── Dearrangement.hs ├── Permutations2.hs ├── Matrix.hs ├── Combinations.hs ├── ParaListComp.hs ├── PrimeNumbers.hs ├── EightQueens.hs ├── Caesar.hs └── ShortestPath.hs ├── C19 ├── main.hs └── macro1.hs ├── C12 ├── Random.hs ├── Stack.hs ├── StackCalc │ ├── Main.hs │ ├── Scanner.hs │ └── Calculator.hs ├── Relation.hs ├── LabelTree.hs ├── MergeSort.hs ├── MWC.hs ├── Reader.hs ├── VarBind.hs ├── Writer.hs └── State.hs ├── C09 ├── Derive1.hs ├── Functor.hs ├── VarArg.hs ├── FoldableTest.hs ├── Num.hs ├── Overloading.hs ├── derive.hs ├── Existential.hs ├── Applicative.hs ├── Instance.hs ├── TraversableTest.hs ├── TraversableTest2.hs └── Parser.hs ├── C07 ├── Composition.hs ├── HigherOrderFunctions.hs └── Fold.hs ├── C08 ├── DataKinds.hs ├── IsoProperty.hs ├── IsoEither.hs ├── EmptyDataType.hs ├── Catalan.hs ├── Induction.hs ├── RoserTreeZipper.hs ├── Zipper2.hs ├── GADTs.hs ├── Isomorphism.hs ├── Kind.hs ├── ZipperXML.hs ├── Newtype.hs ├── Huffman.hs ├── Zipper.hs ├── TwentyFour.hs ├── Sugar.hs ├── LogicCalculator.hs └── DataType.hs ├── C05 ├── BinarySearch.hs ├── Fix.hs ├── Hanoi.hs ├── Newton.hs ├── Rome.hs ├── Recursion.hs ├── Fib.hs ├── chapter05.hs └── Sort.hs ├── C13 ├── MonadBase.hs ├── MonadOrder.hs ├── StateMaybe.hs ├── MonadLift.hs ├── Transformer2.hs ├── MonadOrder2.hs ├── MonadComp.hs ├── Parser.hs ├── Transformer.hs └── Compiler.hs ├── C10 ├── Identity.hs ├── Maybe.hs └── SafeEval.hs ├── C14 ├── ContMonad2.hs ├── Continuation.hs ├── StreamTest.hs ├── ConduitTest.hs ├── ConduitPi.hs ├── IterateeTest.hs ├── FreeMonad1.hs ├── PipesTest.hs ├── FreeMonad2.hs ├── FreeMonad3.hs ├── ContMonad3.hs ├── ContMonad1.hs ├── ParserCalc.hs ├── Calculator.hs ├── Parser.hs └── Iteratee.hs ├── C21 ├── HelloClouldWorld.hs ├── TypeChannel.hs ├── TemplateRemoteSpawn.hs ├── Async.hs ├── PingPong.hs ├── RemoteSpawn.hs ├── SpawnSupervised.hs └── CountServer.hs ├── C25 ├── classDict.hs ├── cat1.hs ├── falg.hs ├── cat0.hs ├── cat3.hs ├── ArrowAndMonad.hs └── ArrowAndApplicative.hs ├── C24 ├── ContinuationFRPTest.hs ├── BouncingBall.hs ├── YampaIntro.hs └── ContinuationFRP.hs ├── C04 └── chapter04.hs ├── C23 ├── Parser.hs └── SF.hs ├── C02 └── chapter02.hs └── C03 └── Booleans.hs /C16/KindPoly.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /C01/Helloworld.hs: -------------------------------------------------------------------------------- 1 | main = putStrLn "Hello World!" -------------------------------------------------------------------------------- /C18/person.json: -------------------------------------------------------------------------------- 1 | {"name" : "Nuo" , "age" : 27} 2 | -------------------------------------------------------------------------------- /C20/ModuleCheck.hs: -------------------------------------------------------------------------------- 1 | import TestAll 2 | 3 | main = runTests 4 | -------------------------------------------------------------------------------- /C16/id.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -ddump-simpl #-} 2 | id'' :: t -> t 3 | id'' x = x -------------------------------------------------------------------------------- /C22/myhaskell/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Introduction_to_Haskell_2ed_source 2 | 这是Haskell函数式编程入门第2版的源码 3 | -------------------------------------------------------------------------------- /C22/Stack1.hs: -------------------------------------------------------------------------------- 1 | import Data.Proxy 2 | 3 | 4 | -- 无法携带kind信息 5 | foo :: Proxy [] 6 | foo = Proxy 7 | -------------------------------------------------------------------------------- /C22/Fib.o: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/HaskellZhangSong/Introduction_to_Haskell_2ed_source/HEAD/C22/Fib.o -------------------------------------------------------------------------------- /C22/Fib.exe: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/HaskellZhangSong/Introduction_to_Haskell_2ed_source/HEAD/C22/Fib.exe -------------------------------------------------------------------------------- /C18/TestZipN2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# OPTIONS_GHC -ddump-splices #-} 3 | import ZipN 4 | zips 5 | -------------------------------------------------------------------------------- /C18/ZipNTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# OPTIONS_GHC -ddump-splices #-} 3 | import ZipN 4 | zips 5 | -------------------------------------------------------------------------------- /C11/Dict/longman.idx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/HaskellZhangSong/Introduction_to_Haskell_2ed_source/HEAD/C11/Dict/longman.idx -------------------------------------------------------------------------------- /C16/MR.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MonomorphismRestriction #-} 2 | {-# OPTIONS_GHC -ddump-simpl #-} 3 | -- x :: Integer 4 | x = 1 + 1 5 | -------------------------------------------------------------------------------- /C16/MR2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction #-} 2 | {-# OPTIONS_GHC -ddump-simpl #-} 3 | -- x :: Num a => a 4 | x = 1 + 1 5 | -------------------------------------------------------------------------------- /C16/RecordFields.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | module M where 3 | data S = MkS { x :: Int } 4 | data T = MkT { x :: Bool } 5 | -------------------------------------------------------------------------------- /C11/name.hs: -------------------------------------------------------------------------------- 1 | main::IO () 2 | main = do 3 | putStr "what is your name?" 4 | name <- getLine 5 | putStrLn $ "Hello " ++ name -------------------------------------------------------------------------------- /C17/GeneratedGenericClassInstances.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -ddump-deriv #-} 2 | import GHC.Generics 3 | data G = GInt {g :: Int} deriving Generic 4 | -------------------------------------------------------------------------------- /C06/ListComp.hs: -------------------------------------------------------------------------------- 1 | filter' f xs = [x| x<-xs, f x] 2 | 3 | series :: Int -> [Double] 4 | series n = [1 / (2 * (fromIntegral k) + 1) * (-1)^k| k <- [0..n]] 5 | -------------------------------------------------------------------------------- /C19/main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Main where 4 | 5 | #ifdef SONG 6 | song = 10 7 | #else 8 | song = 20 9 | #endif 10 | 11 | main = print song 12 | -------------------------------------------------------------------------------- /C12/Random.hs: -------------------------------------------------------------------------------- 1 | import System.Random 2 | 3 | rollDice :: Int -> IO () 4 | rollDice n = do 5 | gen <- newStdGen 6 | print $ take n (randomRs ((1,6)::(Int,Int)) gen) -------------------------------------------------------------------------------- /C11/foreverName.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | main = forever (do 3 | print "Can you tell me your name?" 4 | name <- getLine 5 | print ("Hello " ++ name)) -------------------------------------------------------------------------------- /C09/Derive1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | 3 | class MyShow a where 4 | myshow :: a -> String 5 | myshow _ = "default" 6 | 7 | data Person = P String Int 8 | instance MyShow Person 9 | -------------------------------------------------------------------------------- /C16/FunDep.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies, MultiParamTypeClasses #-} 2 | class Collection e ce | ce -> e where 3 | empty :: ce 4 | insert :: e -> ce -> ce 5 | member :: e -> ce -> Bool 6 | -------------------------------------------------------------------------------- /C18/TypeArityTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# OPTIONS_GHC -ddump-splices #-} 3 | import TypeArity 4 | import Data.Proxy 5 | 6 | makeTypeArity ''Int 7 | makeTypeArity ''Either 8 | makeTypeArity ''(,) -------------------------------------------------------------------------------- /C11/argsTest.hs: -------------------------------------------------------------------------------- 1 | import System.Environment 2 | 3 | main = do 4 | args <- getArgs 5 | case args of 6 | [] -> print "please input some arguments" 7 | arg -> mapM_ print args -------------------------------------------------------------------------------- /C22/Fib.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | fib 0 = 1 4 | fib 1 = 1 5 | fib n = fib (n-1) + {-# SCC fib_30 #-} fib (n-2) 6 | 7 | main = do 8 | print $ {-# SCC fib_30 #-} fib 30 9 | print $ {-# SCC fib_20 #-} fib 20 10 | -------------------------------------------------------------------------------- /C06/transpose.hs: -------------------------------------------------------------------------------- 1 | transpose :: [[a]] -> [[a]] 2 | transpose [] = [] 3 | transpose ([]:xss) = transpose xss 4 | transpose ((x:xs) : xss) = (x : [h | (h:_) <- xss]) : 5 | transpose (xs : [ t | (_:t) <- xss]) -------------------------------------------------------------------------------- /C16/InjectiveTypeFamiliesTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies,TypeFamilyDependencies #-} 2 | 3 | type family F a 4 | type instance F Int = Char 5 | type instance F Bool = Char 6 | 7 | type family B a = b | b -> a 8 | 9 | 10 | -------------------------------------------------------------------------------- /C16/TypeFamily3.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | import Data.Vector 4 | import Data.Sequence 5 | data family Array a 6 | data instance Array Int = MkArrayInt (Vector Int) 7 | data instance Array Char = MkArrayChar (Seq Char) -------------------------------------------------------------------------------- /C20/TestAll.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# OPTIONS_GHC -ddump-splices #-} 3 | module TestAll where 4 | import Test.QuickCheck.All 5 | import QuickCheck1 (prop_bar,prop_foo,check) 6 | 7 | test = check 8 | 9 | 10 | -------------------------------------------------------------------------------- /C11/Dict/longman.ifo: -------------------------------------------------------------------------------- 1 | StarDict's dict ifo file 2 | version=2.4.2 3 | wordcount=43052 4 | idxfilesize=771616 5 | bookname=Longman Dictionary of Contemporary English 6 | description=Made by Hu Zheng 7 | date=2005.10.23 8 | sametypesequence=m 9 | -------------------------------------------------------------------------------- /C07/Composition.hs: -------------------------------------------------------------------------------- 1 | f,g,h :: Num a => a -> a 2 | f x = 4*x+1 3 | g x = x^2+1 4 | h x = f (g x) 5 | 6 | infix 9 >> 7 | (>>) :: (a -> b) -> (b -> c) -> (a -> c) 8 | (>>) = flip (.) 9 | 10 | (|>) :: b -> (b -> c) -> c 11 | (|>) = flip ($) -------------------------------------------------------------------------------- /C08/DataKinds.hs: -------------------------------------------------------------------------------- 1 | -- DataKinds.hs 2 | {-# LANGUAGE GADTs, DataKinds, KindSignatures #-} 3 | 4 | data KEmpty = Empty | NonEmpty 5 | data List :: * -> KEmpty -> * where 6 | Nil :: List a Empty 7 | Cons :: a -> List a b -> List a NonEmpty -------------------------------------------------------------------------------- /C08/IsoProperty.hs: -------------------------------------------------------------------------------- 1 | 2 | f :: (a,b) -> c 3 | f = undefined 4 | 5 | g :: a' -> a 6 | g = undefined 7 | 8 | (><) :: (a -> b) -> (c -> d) -> (a,c) -> (b,d) 9 | (><) f g (a,b) = (f a, g b) 10 | 11 | l = curry f . g 12 | r = curry (f. (g >< id)) -------------------------------------------------------------------------------- /C09/Functor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | data Tree a = Leaf | Node a (Tree a) (Tree a) deriving (Show, Eq, Functor) 3 | 4 | data Container a = Container a Int 5 | instance Functor Container where 6 | fmap g (Container x i) = Container (g x) (i+1) -------------------------------------------------------------------------------- /C11/bool.hs: -------------------------------------------------------------------------------- 1 | import Data.IORef 2 | 3 | bool :: IO () 4 | bool = do 5 | bRef <- newIORef True 6 | modifyIORef bRef not 7 | b <- readIORef bRef 8 | print b 9 | writeIORef bRef True 10 | b <- readIORef bRef 11 | print b -------------------------------------------------------------------------------- /C08/IsoEither.hs: -------------------------------------------------------------------------------- 1 | -- IsoEither.hs 2 | f :: (a, Either b c) -> Either (a,b) (a,c) 3 | f (a, Left b) = Left (a,b) 4 | f (a, Right c) = Right (a,c) 5 | 6 | g :: Either (a,b) (a,c) -> (a, Either b c) 7 | g (Left (a, b)) = (a, Left b) 8 | g (Right (a, c)) = (a, Right c) 9 | -------------------------------------------------------------------------------- /C06/Permutations.hs: -------------------------------------------------------------------------------- 1 | -- Permutation.hs 2 | insert :: a -> [a] -> [[a]] 3 | insert n [] = [[n]] 4 | insert n (n':ns) = (n:n':ns):[n':ns'|ns'<-insert n ns] 5 | 6 | permutation [] = [[]] 7 | permutation (x:xs)= concat [insert x permuxs|permuxs<-permutation xs] 8 | 9 | -------------------------------------------------------------------------------- /C16/Person.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | import Data.Typeable 3 | 4 | data Person = Person String Bool deriving (Show, Typeable) 5 | 6 | equalTypes :: (Typeable a , Typeable b) => a -> b -> Bool 7 | equalTypes a b = if typeOf a == typeOf b then True else False 8 | -------------------------------------------------------------------------------- /C06/Dearrangement.hs: -------------------------------------------------------------------------------- 1 | -- Derangements.hs 2 | import Data.List (delete) 3 | 4 | derangements :: [Int] -> [[Int]] 5 | derangements [] = [[]] 6 | derangements l = [x:xs | x <-l,xs<-derangements (delete x l),x /= length l] 7 | 8 | derangements' n = map reverse (derangements [1..n]) -------------------------------------------------------------------------------- /C18/ExprQuoteTest.hs: -------------------------------------------------------------------------------- 1 | -- ExprQuoteTest.hs 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# OPTIONS_GHC -ddump-splices #-} 4 | import ExprQuote 5 | 6 | foo [expr|x+1|]= [expr|1+1|] 7 | foo _ = Val 10 8 | 9 | 10 | bar [expr|x+0|] = x 11 | bar [expr|0+x|] = x 12 | bar x = x -------------------------------------------------------------------------------- /C18/Lenses.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | import Control.Lens 3 | data Name = N {_firstName :: String , 4 | _familyName :: String } 5 | deriving (Show, Eq) 6 | 7 | makeLenses ''Name 8 | 9 | name = N "Song" "Zhang" 10 | -------------------------------------------------------------------------------- /C08/EmptyDataType.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls, GADTs #-} 2 | 3 | data Empty 4 | data NonEmpty 5 | 6 | data List a b where 7 | Nil :: List a Empty 8 | Cons :: a -> List a b -> List a NonEmpty 9 | 10 | safeHead :: List a NonEmpty -> a 11 | safeHead (Cons x _) = x -------------------------------------------------------------------------------- /C09/VarArg.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances#-} 2 | 3 | class Addition t where 4 | add :: Int -> t 5 | 6 | instance Addition Int where 7 | add x = x 8 | 9 | instance (Addition t) => Addition (Int -> t) where 10 | add i = \x -> add (x+i) 11 | -------------------------------------------------------------------------------- /C05/BinarySearch.hs: -------------------------------------------------------------------------------- 1 | -- BinarySearch.hs 2 | search :: (Ord a) => a -> [a] -> Bool 3 | search a [] = False 4 | search a xs | m < a = search a behind 5 | | m > a = search a front 6 | | otherwise = True 7 | where (front,m:behind) = splitAt (length xs `div` 2) xs -------------------------------------------------------------------------------- /C16/TypeFamily2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies,MultiParamTypeClasses,FlexibleInstances #-} 2 | type family Elem a :: * 3 | type instance Elem [e] = e 4 | 5 | class (Elem ce ~ e) => Collection e ce where 6 | empty :: ce 7 | insert :: e -> ce -> ce 8 | member :: e -> ce -> Bool 9 | -------------------------------------------------------------------------------- /C13/MonadBase.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.Base 2 | import Control.Monad.State 3 | import Control.Monad.Writer 4 | import Data.Functor.Identity 5 | 6 | foo = Identity "hello" 7 | 8 | bar,boo :: Monoid w => StateT s (WriterT w Identity) String 9 | bar = lift $ lift foo 10 | boo = liftBase foo 11 | -------------------------------------------------------------------------------- /C18/PersonValueProviderTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# OPTIONS_GHC -ddump-splices #-} 3 | import PersonValueProvider 4 | import Language.Haskell.TH.Quote 5 | 6 | song_ZHANG = [personJSON| {"name" : "Song ZHANG", "age":26} |] 7 | nuo_LI = [personJSON_file|person.json|] -- 文件名无空格时牛津括号内也不能有空格 -------------------------------------------------------------------------------- /C08/Catalan.hs: -------------------------------------------------------------------------------- 1 | data Tree = Leaf | Node Tree Tree deriving Show 2 | 3 | trees :: Int -> [Tree] 4 | trees 0 = [Leaf] 5 | trees n = [Node lt rt | l <-[0..(n-1)], lt <- trees l , rt <- trees (n-1-l)] 6 | 7 | brace :: Tree -> String 8 | brace Leaf = "" 9 | brace (Node l r) = '(':brace l ++")" ++ brace r 10 | -------------------------------------------------------------------------------- /C08/Induction.hs: -------------------------------------------------------------------------------- 1 | data BoolExp = TRUE | FALSE | IF BoolExp BoolExp BoolExp 2 | deriving (Eq, Show) 3 | 4 | eval :: BoolExp -> Bool 5 | eval TRUE = True 6 | eval FALSE = False 7 | eval (IF con b1 b2) | eval con == True = eval b1 8 | | eval con == False = eval b2 9 | -------------------------------------------------------------------------------- /C05/Fix.hs: -------------------------------------------------------------------------------- 1 | halt :: Integral a => a -> [a] 2 | halt 1 = [1] 3 | halt n | even n = let n' = div n 2 in n':halt n' 4 | | otherwise = let n' = 3*n+1 in n':halt n' 5 | 6 | fix :: (a -> a) -> a 7 | fix f = f (fix f) 8 | 9 | factorial :: Int -> Int 10 | factorial = fix (\f n -> if (n==0) then 1 else n * f (n-1)) 11 | -------------------------------------------------------------------------------- /C18/Lift.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | import Language.Haskell.TH.Syntax 3 | import Control.Applicative 4 | 5 | data Option a = None | Some a deriving (Show, Eq) 6 | 7 | instance Lift a => Lift (Option a) where 8 | lift None = return (ConE 'None) 9 | lift (Some a) = liftA (ConE 'Some `AppE`) (lift a) 10 | -------------------------------------------------------------------------------- /C05/Hanoi.hs: -------------------------------------------------------------------------------- 1 | -- Hanoi.hs 2 | move :: (Int, Int, Int, Int) -> [(Int, Int)] 3 | move (1,from, to, via) = [(from,to)] 4 | move (n, from, to, via) = move (n-1, from, via, to) ++ 5 | [(from, to)] ++ 6 | move (n-1, via, to, from) 7 | 8 | hanoi n = move (n, 1, 2, 3) -------------------------------------------------------------------------------- /C16/TypeComputation1.hs: -------------------------------------------------------------------------------- 1 | -- TypeComputation1.hs 2 | {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, 3 | FlexibleInstances, UndecidableInstances #-} 4 | data Zero 5 | data Succ a 6 | 7 | class Add a b ab | a b -> ab, a ab -> b 8 | instance Add Zero b b 9 | instance (Add a b ab) => Add (Succ a) b (Succ ab) 10 | -------------------------------------------------------------------------------- /C06/Permutations2.hs: -------------------------------------------------------------------------------- 1 | import Data.List (delete) 2 | 3 | permutation :: Eq a => [a] -> [[a]] 4 | permutation [] = [[]] 5 | permutation xs = [y:ys| y<-xs, ys<-permutation (delete y xs)] 6 | 7 | permutation' :: Eq a => Int -> [a] -> [[a]] 8 | permutation' 0 _ = [[]] 9 | permutation' n l = [x:xs | x<-l , xs <- permutation' (n-1) (delete x l)] 10 | -------------------------------------------------------------------------------- /C10/Identity.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | newtype Identity a = Identity { runIdentity :: a } deriving Functor 3 | 4 | instance Applicative Identity where 5 | pure a = Identity a 6 | (<*>) (Identity f) (Identity a) = Identity (f a) 7 | 8 | instance Monad Identity where 9 | return a = Identity a 10 | (Identity m) >>= k = k m 11 | -------------------------------------------------------------------------------- /C17/GenericByteString.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, UndecidableInstances, OverloadedStrings #-} 2 | import GHC.Generics 3 | import GHC.Word 4 | import Data.ByteString 5 | 6 | instance Generic ByteString where 7 | type Rep ByteString = Rep [Word8] 8 | from bs = from (unpack bs) 9 | to w = pack $ (to w) 10 | 11 | abc = from ("abc":: ByteString) 12 | -------------------------------------------------------------------------------- /C16/Test.hs: -------------------------------------------------------------------------------- 1 | -- Test.hs 2 | {-# LANGUAGE FlexibleInstances, UndecidableInstances #-} 3 | class C a where 4 | foo :: a -> IO () 5 | 6 | class A a where 7 | instance A Bool 8 | instance A Int 9 | 10 | instance (A a) => C a where 11 | foo = undefined 12 | 13 | class B a where 14 | instance B Char 15 | instance B Double 16 | 17 | -- instance (B a) => C a where 18 | -------------------------------------------------------------------------------- /C17/FunctorGeneric.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric,DefaultSignatures,KindSignatures,FlexibleContexts #-} 2 | import GHC.Generics 3 | 4 | class GFunctor (f :: * -> *) where 5 | gfmap :: (a -> b) -> (f a -> f b) 6 | default gfmap :: (Generic1 f, GFunctor (Rep1 f)) => (a -> b) -> (f a -> f b) 7 | gfmap = defaultfmap 8 | 9 | defaultfmap = undefined -- 10 | -------------------------------------------------------------------------------- /C06/Matrix.hs: -------------------------------------------------------------------------------- 1 | import Data.List (transpose) 2 | 3 | infixl 5 |*| 4 | 5 | (|*|) :: Num a => [[a]] -> [[a]] -> [[a]] 6 | (|*|) a b = [[ sum $ zipWith (*) ar bc | bc <- transpose b ] | ar <- a] 7 | 8 | unit = [[1,1],[1,0]] 9 | 10 | fib 1 = unit 11 | fib n | even n = let m = fib (div n 2) in m |*| m 12 | | otherwise = let m = fib (div (n-1) 2) in m |*| unit |*| m -------------------------------------------------------------------------------- /C16/Rank.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | foo :: (forall a . [a] -> [a]) -> ([b],[c]) -> ([b],[c]) 3 | foo f (xs,ys)= (f xs, f ys) 4 | 5 | bar :: ([a] -> [a]) -> [a] -> [a] 6 | bar f xs = f xs 7 | 8 | bar' :: (forall a. [a] -> [a]) -> [a] -> [a] 9 | bar' f xs = f xs 10 | 11 | bar'' :: Num b => (forall a. Num a => [a] -> [a]) -> [b] -> [b] 12 | bar'' f xs = f xs 13 | -------------------------------------------------------------------------------- /C16/TypeFamily.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | class Collection ce where 3 | type Element ce :: * 4 | empty :: ce 5 | insert :: Element ce -> ce -> ce 6 | member :: Element ce -> ce -> Bool 7 | 8 | instance Eq a => Collection [a] where 9 | type Element [a] = a 10 | empty = [] 11 | insert x xs = x:xs 12 | member x xs = elem x xs 13 | -------------------------------------------------------------------------------- /C14/ContMonad2.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.Cont 2 | 3 | fib_cps :: Int -> ContT r IO Int 4 | fib_cps 0 = return 1 5 | fib_cps 1 = return 1 6 | fib_cps n = do 7 | n2 <- fib_cps (n-2) 8 | liftIO $ putStrLn $ "fib_cps " ++ show (n-2) ++ "=" ++ show n2 9 | n1 <- fib_cps (n-1) 10 | liftIO $ putStrLn $ "fib_cps " ++ show (n-1) ++ "=" ++ show n1 11 | return (n1 + n2) 12 | -------------------------------------------------------------------------------- /C09/FoldableTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | 3 | import Data.Foldable 4 | import Data.Monoid 5 | 6 | data Tree a = Leaf a | Node (Tree a) a (Tree a) 7 | deriving Show 8 | 9 | instance Foldable Tree where 10 | foldMap f (Leaf x) = f x 11 | foldMap f (Node l n r) = foldMap f l `mappend` f n `mappend` foldMap f r 12 | 13 | tree = Node (Leaf 1) 5 (Node (Leaf 0) 2 (Leaf 3)) 14 | -------------------------------------------------------------------------------- /C09/Num.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | import Control.Applicative 4 | 5 | instance Num b => Num (a -> b) where 6 | (+) = liftA2 (+) 7 | (-) = liftA2 (-) 8 | (*) = liftA2 (*) 9 | abs = liftA abs 10 | signum = liftA abs 11 | negate = fmap negate 12 | fromInteger = pure.fromInteger 13 | 14 | instance Integral a => Integral (a -> b) where -------------------------------------------------------------------------------- /C09/Overloading.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | data Rect = Rect Double Double 3 | data Circle = Circle Double 4 | 5 | class HasArea t where 6 | area :: t -> Double 7 | 8 | instance HasArea Rect where 9 | area (Rect a b) = a * b 10 | 11 | instance HasArea Circle where 12 | area (Circle r) = pi * r * r 13 | 14 | data Shape where 15 | Shape :: HasArea t => t -> Shape -------------------------------------------------------------------------------- /C08/RoserTreeZipper.hs: -------------------------------------------------------------------------------- 1 | import Data.Tree 2 | import Data.Tree.Zipper 3 | import Data.Function 4 | import Data.Maybe 5 | 6 | directory :: Tree String 7 | directory = Node "Home" 8 | [Node "Picture" [Node "travel" [] , Node "family" []], 9 | Node "Video" [Node "Fast and Furious" [], Node "True Lies" []], 10 | Node "Music" [Node "My love" [], Node "Destiny" []]] 11 | 12 | -------------------------------------------------------------------------------- /C09/derive.hs: -------------------------------------------------------------------------------- 1 | -- derive.hs 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# OPTIONS_GHC -ddump-splices #-} 4 | 5 | import Data.Derive.Class.Arities 6 | import Data.Derive.Arities 7 | import Data.Derive.Show 8 | import Data.Derive.Eq 9 | import Data.DeriveTH 10 | 11 | data Shape = Circle Double | Triangle Double Double Double 12 | 13 | derive makeEq ''Shape 14 | derive makeShow ''Shape 15 | derive makeArities ''Shape -------------------------------------------------------------------------------- /C16/ImplicitParams.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ImplicitParams #-} 2 | import Data.List 3 | 4 | sortBy' :: Ord a => (a -> a -> Bool) -> [a] -> [a] 5 | sortBy' f xs = sortBy cmp xs 6 | where cmp x y = if f x y then LT else GT 7 | 8 | sort' :: (?cmp :: a -> a -> Bool) => Ord a => [a] -> [a] 9 | sort' = sortBy' ?cmp 10 | 11 | least xs = head (sort' xs) 12 | 13 | maxnum = let ?cmp = ((>) :: Int -> Int -> Bool) in least -------------------------------------------------------------------------------- /C05/Newton.hs: -------------------------------------------------------------------------------- 1 | fix :: Eq a => (a -> a) -> a 2 | fix f x | x == f x = x 3 | | otherwise = fix f (f x) 4 | 5 | squareroot :: Int -> Double -> Double 6 | squareroot 0 x = x 7 | squareroot n x = (squareroot (n-1) x + x / squareroot (n-1) x )/2 8 | 9 | newton :: Fractional a => a -> a -> a 10 | newton c t = (c/t + t) /2.0 11 | 12 | mysqrt :: Double -> Double 13 | mysqrt c = fix (\a b -> a - b < 0.000001) (newton c) c 14 | 15 | -------------------------------------------------------------------------------- /C12/Stack.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.State 2 | type Stack = [Int] 3 | 4 | pop :: State Stack Int 5 | pop = state $ \(x:xs) -> (x,xs) 6 | 7 | peek :: State Stack Int 8 | peek = state $ \(x:xs) -> (x,x:xs) 9 | 10 | push :: Int -> State Stack () 11 | push i = state $ \xs -> ((), i:xs) 12 | 13 | addStack :: State Stack () 14 | addStack = do 15 | a1 <- pop 16 | a2 <- pop 17 | let a3 = a1+a2 18 | push a3 19 | -------------------------------------------------------------------------------- /C16/GEq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses,FlexibleInstances #-} 2 | 3 | class GEq a b where 4 | geq :: a -> b -> Bool 5 | 6 | instance {-# OVERLAPPABLE #-}Real b => GEq Double b where 7 | geq a b = toRational a == toRational b 8 | 9 | instance {-# OVERLAPPABLE #-} Real a => GEq a Double where 10 | geq a b = toRational a == toRational b 11 | 12 | instance {-# OVERLAPPING #-} GEq Double Double where 13 | geq a b = toRational a == toRational b 14 | -------------------------------------------------------------------------------- /C16/RuntimeRep.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE RankNTypes, TypeInType #-} 3 | 4 | import GHC.Types 5 | import GHC.Prim 6 | 7 | f :: Int -> Int# 8 | f (I# i) = undefined 9 | 10 | -- undefined' :: forall (r :: RuntimeRep) (a :: TYPE r). a 11 | undefined' = undefined 12 | 13 | -- f' :: Int -> Int# 14 | -- f' (I# i) = undefined' 15 | 16 | g :: Int -> Int# 17 | g (I# i) = i 18 | 19 | id' :: forall (v :: RuntimeRep) (a :: TYPE r) . a -> a 20 | id' x = x 21 | -------------------------------------------------------------------------------- /C08/Zipper2.hs: -------------------------------------------------------------------------------- 1 | data Tree a = Leaf a | Node a (Tree a) (Tree a) 2 | 3 | data Branch a = R a (Tree a) | L a (Tree a) 4 | 5 | type Zipper a = (Tree a, [Branch a]) 6 | 7 | right, left, up :: Zipper a -> Zipper a 8 | 9 | right (Node n l r, t) = (r, R n l: t) 10 | right z@(Leaf a, t) = z 11 | 12 | left (Node n l r, t) = (l, L n r :t) 13 | left z@(Leaf a, t) = z 14 | 15 | up (r, (R n l: t)) = (Node n l r ,t) 16 | up (l, (L n r: t)) = (Node n l r ,t) 17 | up z@(t, []) = z -------------------------------------------------------------------------------- /C16/InstanceMatchTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses,FlexibleContexts #-} 2 | 3 | class I a b where 4 | ifoo :: a -> b -> String 5 | 6 | instance {-# OVERLAPPABLE #-} I a [b] where 7 | ifoo _ _ = "I a [b]" 8 | 9 | instance {-# INCOHERENT #-} I a [a] where 10 | ifoo _ _ = "I a [a]" 11 | 12 | instance {-# OVERLAPPABLE #-} I Int [a] where 13 | ifoo _ _ = "I Int [a]" 14 | 15 | foo :: I a [b] => a -> [b] -> String 16 | foo a b = ifoo a b 17 | -------------------------------------------------------------------------------- /C08/GADTs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | data Exp a where 4 | ValInt :: Int -> Exp Int 5 | ValBool :: Bool -> Exp Bool 6 | Add :: Exp Int -> Exp Int -> Exp Int 7 | Equa :: Exp Int -> Exp Int -> Exp Bool 8 | 9 | eval :: Exp a -> a 10 | eval (ValInt i) = i 11 | eval (ValBool b) = b 12 | eval (Add e1 e2) = eval e1 + eval e2 13 | eval (Equa e1 e2) = eval e1 == eval e2 14 | 15 | data Tree a where 16 | Leaf :: a -> Tree Int 17 | Branch :: Tree a -> Tree a -> Tree Int -------------------------------------------------------------------------------- /C21/HelloClouldWorld.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Distributed.Process 4 | import Control.Distributed.Process.Node (initRemoteTable, runProcess) 5 | import Control.Distributed.Process.Backend.SimpleLocalnet 6 | 7 | main :: IO () 8 | main = do 9 | backend <- initializeBackend "localhost" "8000" initRemoteTable 10 | node <- newLocalNode backend 11 | runProcess node $ do 12 | self <- getSelfPid 13 | send self "Hello world" 14 | "Hello world" <- expect 15 | return () 16 | -------------------------------------------------------------------------------- /C14/Continuation.hs: -------------------------------------------------------------------------------- 1 | fact_cps :: (Eq a, Num a) => a -> (a -> t) -> t 2 | fact_cps 0 k = k 1 3 | fact_cps n k = fact_cps (n-1) (\x -> k (n * x)) 4 | 5 | type Cont a r = (a -> r) -> r 6 | 7 | fib_cps :: Int -> (Int -> r) -> r 8 | fib_cps 0 k = k 1 9 | fib_cps 1 k = k 1 10 | fib_cps n k = fib_cps (n-1) (\n1 -> fib_cps (n-2) (\n2 -> k (n1 + n2))) 11 | 12 | fib_cps' :: Int -> (Int -> r) -> r 13 | fib_cps' 0 k = k 1 14 | fib_cps' 1 k = k 1 15 | fib_cps' n k = fib_cps (n-2) (\n2 -> fib_cps (n-1) (\n1 -> k (n2 + n1))) 16 | -------------------------------------------------------------------------------- /C14/StreamTest.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.Stream 2 | import Control.Monad 3 | 4 | nats = return 0 `mplus` (nats >>= (return . (+1))) 5 | 6 | natpair :: Stream (Int,Int) 7 | natpair= do 8 | i <- nats 9 | j <- nats 10 | return (i,j) 11 | 12 | pythagorean_triples :: Stream (Int,Int,Int) 13 | pythagorean_triples = do 14 | i <- nats 15 | guard $ i > 0 16 | j <- nats 17 | guard $ j > 0 18 | k <- nats 19 | guard $ k > 0 20 | guard $ i*i + j*j == k*k 21 | return (i,j,k) 22 | 23 | -------------------------------------------------------------------------------- /C08/Isomorphism.hs: -------------------------------------------------------------------------------- 1 | data ThreeNum = One | Two | Three 2 | data Level = Low | Middle | High 3 | 4 | f :: ThreeNum -> Level 5 | f One = Low 6 | f Two = Middle 7 | f Three = High 8 | 9 | g :: Level -> ThreeNum 10 | g Low = One 11 | g Middle = Two 12 | g High = Three 13 | 14 | data Unit = Unit 15 | data List a = Nil | Cons a (List a) 16 | data Nat = Zero | Succ Nat 17 | 18 | list2Nat Nil = Zero 19 | list2Nat (Cons x xs) = Succ (list2Nat xs) 20 | 21 | nat2List Zero = Nil 22 | nat2List (Succ n) = Cons Unit (nat2List n) 23 | -------------------------------------------------------------------------------- /C12/StackCalc/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | import Calculator (calc,inits,Lit (Val),LitOp) 3 | import Scanner (scanExp) 4 | import System.Environment (getArgs) 5 | import Control.Monad.State (evalState) 6 | 7 | cal :: String -> LitOp 8 | cal exp = (evalState.calc.scanExp) exp inits 9 | 10 | num :: LitOp -> Float 11 | num (Left (Val a)) = a 12 | num _ = error "input error" 13 | 14 | calculate = num.cal 15 | 16 | main :: IO () 17 | main = do 18 | expr <- getArgs 19 | print $ calculate $ concat expr 20 | -------------------------------------------------------------------------------- /C16/DependentType.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | data Vec a (n :: Nat) where 4 | Nil :: Vec a Z 5 | Cons :: a -> Vec a n -> Vec a (S n) 6 | 7 | deriving instance Show a => Show (Vec a n) 8 | 9 | vhead :: Vec a (S n) -> a 10 | vhead (Cons a v) = a 11 | 12 | vtail :: Vec a (S n) -> Vec a n 13 | vtail (Cons x xs) = xs 14 | 15 | append :: Vec a n -> Vec a m -> Vec a (n + m) 16 | append (Cons x xs) ys = Cons x (append xs ys) 17 | append Nil ys = ys 18 | 19 | toList :: Vec a n -> [a] 20 | toList Nil = [] 21 | toList (Cons x xs) = x : toList xs -------------------------------------------------------------------------------- /C05/Rome.hs: -------------------------------------------------------------------------------- 1 | -- Rome.hs 2 | romeNotation :: [String] 3 | romeNotation= ["M","CM","D","CD","C","XC","L","XL","X","IX","V","IV","I"] 4 | 5 | romeAmount :: [Int] 6 | romeAmount = [1000,900, 500, 400, 100, 90, 50, 40, 10, 9, 5, 4, 1] 7 | 8 | pair :: [(Int, String)] 9 | pair = zip romeAmount romeNotation 10 | 11 | subtrahend :: Int -> (Int, String) 12 | subtrahend n = head (dropWhile (\(a,_) -> a > n) pair) 13 | 14 | convert :: Int -> String 15 | convert 0 = "" 16 | convert n = let (rome, m) = subtrahend n 17 | in m ++ convert (n-rome) 18 | -------------------------------------------------------------------------------- /C06/Combinations.hs: -------------------------------------------------------------------------------- 1 | -- Combinations.hs 2 | import Data.List (tails) 3 | 4 | powerSet = choice (\x -> [True,False]) 5 | 6 | choice :: (a -> [Bool]) -> [a] -> [[a]] 7 | choice _ [] = [[]] 8 | choice f (x:xs) =[if choose then x:ys else ys|choose <- f x , ys<- choice f xs] 9 | 10 | powerSet' :: [a] -> [[a]] 11 | powerSet' [] = [[]] 12 | powerSet' (x:xs) = [x:r | r <- powerSet' xs ] ++ powerSet' xs 13 | 14 | combinations :: Int -> [a] -> [[a]] 15 | combinations 0 _ = [[]] 16 | combinations n xs = [y:ys | y:xs'<- tails xs, ys <- combinations (n-1) xs'] 17 | -------------------------------------------------------------------------------- /C06/ParaListComp.hs: -------------------------------------------------------------------------------- 1 | -- ParaListComp.hs 2 | {-# LANGUAGE ParallelListComp, TransformListComp #-} 3 | import GHC.Exts 4 | 5 | table = [("Hangzhou", "MP4", 243), 6 | ("Hangzhou", "CD" , 925), 7 | ("Beijing" , "MP4", 157), 8 | ("Beijing" , "CD" , 536), 9 | ("Shanghai", "MP4", 784), 10 | ("Shanghai", "CD" , 766)] 11 | 12 | analysis = [(the product, sum cost)| 13 | (city, product, cost) <- table, 14 | then group by product using groupWith, 15 | then sortWith by (sum cost)] -------------------------------------------------------------------------------- /C16/MyShow.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances,OverlappingInstances #-} 2 | 3 | class MyShow a where 4 | myShow :: a -> String 5 | 6 | instance MyShow Int where myShow = show 7 | instance MyShow Char where myShow = show 8 | 9 | instance MyShow a => MyShow [a] where 10 | myShow [] = "[]" 11 | myShow xs = "[" ++ showx xs 12 | where 13 | showx [] = "]" 14 | showx [x] = myShow x ++ "]" 15 | showx (x:xs) = myShow x ++","++ showx xs 16 | 17 | instance MyShow [Char] where 18 | myShow = show 19 | -------------------------------------------------------------------------------- /C20/UnitTest.hs: -------------------------------------------------------------------------------- 1 | -- UnitTest.hs 2 | import Test.HUnit 3 | import Data.List 4 | 5 | foo _ = (1,True) 6 | test1 = TestCase (assertEqual "for (foo 3)" (1,True) (foo 3)) 7 | 8 | 9 | qsort :: Ord a => [a] -> [a] 10 | qsort [] = [] 11 | qsort (p:xs) = qsort lesser ++ [p] ++ qsort greater 12 | where 13 | lesser = [ y | y <- xs, y > p ] 14 | greater = [ y | y <- xs, y >= p ] 15 | 16 | test2 :: Test 17 | test2 = TestCase $ assertBool "for qsort" (let xs = [6,4,7,8,1,2,9,4] 18 | in qsort xs == sort xs) 19 | 20 | 21 | -------------------------------------------------------------------------------- /C13/MonadOrder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | import Control.Monad 3 | 4 | newtype WriterT w m a = WriterT { runWriterT :: m (a, w) } 5 | deriving Functor 6 | 7 | instance (Monoid w, Monad m) => Applicative (WriterT w m) where 8 | pure = return 9 | (<*>) = ap 10 | 11 | instance (Monoid w, Monad m) => Monad (WriterT w m) where 12 | return a = WriterT $ return (a, mempty) 13 | m >>= k = WriterT $ do 14 | (a, w) <- runWriterT m 15 | (b, w') <- runWriterT (k a) 16 | return (b, w `mappend` w') 17 | 18 | 19 | -------------------------------------------------------------------------------- /C21/TypeChannel.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad 4 | 5 | import Control.Distributed.Process 6 | import Control.Distributed.Process.Node (initRemoteTable, runProcess) 7 | import Control.Distributed.Process.Backend.SimpleLocalnet 8 | 9 | example :: Process () 10 | example = do 11 | (sp, rp) <- newChan 12 | void $ spawnLocal (sendChan sp "Hello world") 13 | receiveChan rp >>= liftIO . putStrLn 14 | 15 | main :: IO () 16 | main = do 17 | backend <- initializeBackend "localhost" "8000" initRemoteTable 18 | node <- newLocalNode backend 19 | runProcess node example 20 | -------------------------------------------------------------------------------- /C08/Kind.hs: -------------------------------------------------------------------------------- 1 | -- Kind.hs 2 | {-# LANGUAGE GADTs, KindSignatures, FlexibleInstances #-} 3 | data T :: * -> * where 4 | NIL :: T a 5 | CONS :: a -> T a -> T a 6 | 7 | data AbsTree k a = Leaf a | Node (k (AbsTree k a)) 8 | 9 | data Tree :: (* -> *) -> * -> * where 10 | L :: a -> Tree k a 11 | N :: k (Tree k a) -> Tree k a 12 | 13 | type RoseTree a = Tree [] a 14 | 15 | instance Show a => Show (RoseTree a) where 16 | show (L a) = show a 17 | show (N tree) = show tree 18 | 19 | test :: RoseTree Int 20 | test = N [N[L 5, L 8, N [L 1 , L 2]], N[L 3]] -------------------------------------------------------------------------------- /C05/Recursion.hs: -------------------------------------------------------------------------------- 1 | ones = 1:ones 2 | 3 | nature = 0 : map (+1) nature 4 | 5 | fibs = (0:1:zipWith (+) fibs (tail fibs)) 6 | 7 | shorter :: [a] -> [a] -> [a] 8 | shorter xs ys | x < y = xs 9 | | otherwise ys 10 | where 11 | x = length xs 12 | y = length ys 13 | 14 | lazyShorter :: [a] -> [a] -> [a] 15 | lazyShorter xs ys = if short xs ys then xs else ys 16 | where short [] ys = True 17 | short xs [] = False 18 | short (x:xs) (y:ys) = short xs ys 19 | -------------------------------------------------------------------------------- /C16/Dynamic.hs: -------------------------------------------------------------------------------- 1 | import Data.Dynamic 2 | import Control.Applicative 3 | 4 | matchZero :: Dynamic -> Maybe Int 5 | matchZero d = case fromDynamic d :: Maybe Int of 6 | Nothing -> Nothing 7 | Just c -> if c == 0 then return 0 else Nothing 8 | 9 | matchBool :: Dynamic -> Maybe Int 10 | matchBool d = case fromDynamic d :: Maybe Bool of 11 | Nothing -> Nothing 12 | Just c -> if c then return 1 else return 0 13 | 14 | dynamicMatch :: Dynamic -> Maybe Int 15 | dynamicMatch a = foldl (<|>) Nothing [matchZero a, matchBool a] 16 | -------------------------------------------------------------------------------- /C08/ZipperXML.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes,OverloadedStrings #-} 2 | import Prelude hiding (readFile) 3 | import Text.RawString.QQ 4 | import Data.ByteString.Lazy hiding (length,head) 5 | import Text.XML.Cursor 6 | import Text.XML 7 | import Data.Function 8 | xml :: ByteString 9 | xml = [r| 10 | 11 | My<b> Title1 </b> 12 | My<b> Title2 </b> 13 | My<b> Title3 </b> 14 | 15 | 16 |

Foo

17 |

Bar

18 | 19 | |] 20 | 21 | cursor = fromDocument $ parseLBS_ def xml 22 | -------------------------------------------------------------------------------- /C14/ConduitTest.hs: -------------------------------------------------------------------------------- 1 | import qualified Data.Conduit.List as CL 2 | import Data.Conduit 3 | 4 | l :: Monad m => Source m Int 5 | l = CL.sourceList [1.. 10] 6 | 7 | i :: Monad m => Source m Int 8 | i = CL.sourceList [1.. ] 9 | 10 | alternative :: Monad m => Conduit a m a 11 | alternative = do 12 | p <- await 13 | case p of 14 | Just a -> do 15 | CL.drop 1 16 | yield a 17 | alternative 18 | Nothing -> return () 19 | 20 | sink1 :: Sink Int IO () 21 | sink1 = CL.mapM_ print 22 | 23 | -------------------------------------------------------------------------------- /C07/HigherOrderFunctions.hs: -------------------------------------------------------------------------------- 1 | power2 :: Num a => [a] -> [a] 2 | power2 [] = [] 3 | power2 (x:xs) = x^2 : power2 xs 4 | 5 | plus1 :: Num a => [a] -> [a] 6 | plus1 [] = [] 7 | plus1 (x:xs) = (x+1) : plus1 xs 8 | 9 | fix1 :: (a -> a) -> a 10 | fix1 f = f (fix1 f) 11 | 12 | fix2 :: Eq a => (a -> a) -> a -> a 13 | fix2 f x | x == f x = x 14 | | otherwise = fix2 f (f x) 15 | 16 | fix3 :: (t -> t -> Bool) -> (t -> t) -> t -> t 17 | fix3 c f x | c x (f x) = x 18 | | otherwise = fix3 c f (f x) 19 | 20 | apply :: (a -> a) -> Int -> a -> a 21 | apply f 0 x = x 22 | apply f n x = apply f (n-1) (f x) -------------------------------------------------------------------------------- /C11/SystemProcess.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | 3 | import System.Process 4 | import GHC.IO.Handle 5 | import System.IO 6 | 7 | deriving instance Show (CmdSpec) 8 | deriving instance Show (StdStream) 9 | deriving instance Show (CreateProcess) 10 | 11 | command1 = do 12 | (Nothing,Nothing,Nothing,d) <- 13 | createProcess (proc "ls" []) 14 | return () 15 | 16 | command2 = do 17 | (Nothing,Just b,Nothing,d) <- 18 | createProcess (proc "ls" []) { std_out = CreatePipe } 19 | l <- hGetContents b 20 | return l 21 | -------------------------------------------------------------------------------- /C11/UnsafeIOTest.hs: -------------------------------------------------------------------------------- 1 | import System.IO.Unsafe 2 | import Data.IORef 3 | 4 | ref :: IORef Int 5 | ref = unsafePerformIO $ newIORef 0 6 | 7 | plus :: IO () 8 | plus = do 9 | x <- readIORef ref 10 | y <- writeIORef ref 1 >> return 100 11 | print (x + y) 12 | 13 | plus' :: IO () 14 | plus' = do 15 | x <- unsafeInterleaveIO $ readIORef ref 16 | y <- unsafeInterleaveIO $ writeIORef ref 1 >> return 100 17 | print (x + y) 18 | 19 | plus'' :: IO () 20 | plus'' = do 21 | x <- unsafeInterleaveIO $ readIORef ref 22 | y <- unsafeInterleaveIO $ writeIORef ref 1 >> return 100 23 | print (y + x) 24 | -------------------------------------------------------------------------------- /C18/StandaloneDeriveTest.hs: -------------------------------------------------------------------------------- 1 | -- StandaloneDeriveTest.hs 2 | {-# LANGUAGE TemplateHaskell, StandaloneDeriving, DeriveGeneric, DeriveAnyClass #-} 3 | -- ghcqyl{}使用元编程需要的，之后的ghc{}版本会改。 4 | {-# LANGUAGE KindSignatures,ConstraintKinds #-} 5 | {-# OPTIONS_GHC -ddump-splices #-} 6 | 7 | import DeriveTopdown 8 | import qualified GHC.Generics as G 9 | import qualified Data.Binary as B 10 | import qualified Data.Aeson as A 11 | import qualified Data.Data as D 12 | 13 | data C a b = A (B a) G 14 | data B a = B a | F (D a) 15 | data D b = D b | E b 16 | data G = G 17 | derivings [''Eq, ''G.Generic, ''B.Binary, ''Ord] ''C -------------------------------------------------------------------------------- /C12/Relation.hs: -------------------------------------------------------------------------------- 1 | import Data.Monoid 2 | import Control.Monad.Reader 3 | 4 | type Stack = [Int] 5 | (|>) :: Monoid a => a -> a -> a 6 | (|>) = mappend 7 | 8 | newtype FunApp a = FunApp { appFunApp :: a -> a } 9 | instance Monoid (FunApp a) where 10 | mempty = FunApp id 11 | FunApp f `mappend` FunApp g = FunApp (g . f) 12 | 13 | push :: Int -> FunApp Stack 14 | push i = FunApp $ \xs -> i:xs 15 | 16 | pop :: FunApp Stack 17 | pop = FunApp $ \(x:xs) -> xs 18 | 19 | m :: FunApp Stack 20 | m = push 3 21 | |> push 1 22 | |> pop 23 | 24 | readLength :: Int -> Reader Stack Int 25 | readLength n = reader $ \xs -> length xs -------------------------------------------------------------------------------- /C16/fact.hs: -------------------------------------------------------------------------------- 1 | import Data.STRef 2 | import Control.Monad.ST 3 | 4 | factorial :: Int -> STRef s Int -> ST s Int 5 | factorial n accRef = do 6 | numRef <- newSTRef n 7 | num <- readSTRef numRef 8 | if num < 1 9 | then readSTRef accRef 10 | else do 11 | acc <- readSTRef accRef 12 | writeSTRef accRef (acc * n) 13 | writeSTRef numRef (num - 1) 14 | factorial (num - 1) accRef 15 | 16 | fact :: Int -> Int 17 | fact n = runST $ do 18 | accRef <- newSTRef 1 19 | factorial n accRef 20 | -------------------------------------------------------------------------------- /C08/Newtype.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | newtype T a b = NewType (a,b) 3 | 4 | newtype Stream a = Cons (a, (Stream a)) 5 | 6 | newtype Velocity = Velocity Int deriving (Num, Eq) 7 | newtype Weight = Weight Int deriving (Num, Eq) 8 | newtype Second = Second Int deriving (Num, Eq) 9 | 10 | instance Show Velocity where 11 | show (Velocity n) = show n ++" m/s" 12 | 13 | instance Show Weight where 14 | show (Weight w) = show w ++ " kg" 15 | 16 | instance Show Second where 17 | show (Second 0) = "0 second" 18 | show (Second 1) = "1 second" 19 | show (Second n) = show n ++ " seconds" 20 | -------------------------------------------------------------------------------- /C17/SYB1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, DefaultSignatures,ScopedTypeVariables #-} 2 | import Data.Data 3 | 4 | data E1 = A1 | B1 | C1 Int deriving (Show, Typeable, Data) 5 | data E2 = A2 | B2 | C2 | D2 deriving (Show, Typeable, Data) 6 | data E3 = A3 | B3 | C3 | D3 Int deriving (Show, Typeable, Data) 7 | 8 | class LastConstr a where 9 | default lastConstr :: Data a => a 10 | lastConstr = fromConstr $ last $ dataTypeConstrs (dataTypeOf (undefined :: a)) 11 | lastConstr :: a 12 | 13 | instance LastConstr E1 14 | instance LastConstr E2 15 | instance LastConstr E3 16 | 17 | data E4 = A4 | B4 | C4 | D4 Bool Int Char deriving (Show, Typeable, Data) 18 | -------------------------------------------------------------------------------- /C12/LabelTree.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.State 2 | 3 | data Tree a = Leaf a | Node (Tree a) a (Tree a) deriving (Show,Eq) 4 | 5 | increase :: State Int Int 6 | increase = state $ \i -> (i,i+1) 7 | 8 | ntAux :: Tree a -> State Int (Tree (a,Int)) 9 | ntAux (Leaf a) = do 10 | nl <- increase 11 | return (Leaf (a,nl)) 12 | 13 | ntAux (Node l n r) = do 14 | nl <- increase 15 | lt <- ntAux l 16 | rt <- ntAux r 17 | return (Node lt (n,nl) rt) 18 | 19 | labelTree t = evalState (ntAux t) 0 20 | 21 | test :: Tree Int 22 | test = Node (Node (Leaf 5) 3 (Leaf 2)) 7 (Leaf 9) 23 | -------------------------------------------------------------------------------- /C13/StateMaybe.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.State 2 | import Control.Monad.Trans.Maybe 3 | 4 | pushSM :: Int -> StateT [Int] Maybe () 5 | pushSM x = StateT $ \xs -> Just ((),x:xs) 6 | 7 | popSM :: StateT [Int] Maybe Int 8 | popSM = StateT $ \xs -> case xs of 9 | [] -> Nothing 10 | (x:xs) -> Just (x,xs) 11 | 12 | pushMS :: Int -> MaybeT (State [Int]) () 13 | pushMS x = MaybeT $ state $ \xs -> (Just (),x:xs) 14 | 15 | popMS :: MaybeT (State [Int]) Int 16 | popMS = MaybeT $ state $ \xs -> case xs of 17 | [] -> (Nothing, xs) 18 | (y:ys) -> (Just y, ys) -------------------------------------------------------------------------------- /C09/Existential.hs: -------------------------------------------------------------------------------- 1 | -- Existential.hs 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE GADTs, KindSignatures, ConstraintKinds,CPP #-} 4 | import Data.Constraint 5 | 6 | data Showy = forall a. (Show a) => Showy a 7 | 8 | instance Show Showy where 9 | show (Showy a) = show a 10 | 11 | showType :: [Showy] 12 | showType = [Showy (1::Int), Showy "String", Showy 'c'] 13 | 14 | data Shape = forall a. (HasArea a) => Shape a 15 | 16 | class HasArea t where 17 | area :: t -> Double 18 | 19 | instance HasArea Shape where 20 | area (Shape a) = area a 21 | 22 | data Some :: (* -> Constraint) -> * where 23 | Some :: c a => a -> Some c -------------------------------------------------------------------------------- /C20/QuickCheck1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, DeriveGeneric #-} 2 | module QuickCheck1 where 3 | import Data.DeriveTH 4 | import Data.Derive.Arbitrary 5 | import Test.QuickCheck 6 | import GHC.Generics 7 | import Text.Show.Functions 8 | 9 | data Exp = Val Int 10 | | Add Exp Exp 11 | deriving (Show, Eq, Generic) 12 | 13 | eval :: Exp -> Int 14 | eval (Val x) = x 15 | eval (Add x y) = eval x + eval y 16 | 17 | derive makeArbitrary ''Exp 18 | instance CoArbitrary Exp 19 | 20 | prop_foo :: Exp -> Exp -> Bool 21 | prop_foo x y = eval x /= eval y 22 | 23 | prop_bar :: (Exp -> Int) -> Exp -> Bool 24 | prop_bar f e = f e > 0 25 | 26 | return [] 27 | check = $verboseCheckAll 28 | -------------------------------------------------------------------------------- /C08/Huffman.hs: -------------------------------------------------------------------------------- 1 | import Data.List (insertBy, sortBy) 2 | import Data.Ord (comparing) 3 | 4 | data HTree a = Leaf a | Branch (HTree a) (HTree a) deriving Show 5 | 6 | htree [(_, t)] = t 7 | htree ((w1,t1):(w2,t2):wts) = htree $ insertBy 8 | (comparing fst) 9 | (w1 + w2, Branch t1 t2) wts 10 | 11 | serialize (Leaf x) = [(x, "")] 12 | serialize (Branch l r) = [(x,'0':code)|(x,code)<-serialize l]++[(x,'1':code)| (x,code) <-serialize r] 13 | 14 | huffman :: (Ord a, Ord w, Num w) => [(a,w)] -> [(a,[Char])] 15 | huffman freq = sortBy (comparing fst) $ serialize 16 | $ htree $ sortBy (comparing fst) $ [(w, Leaf x) | (x,w) <- freq] -------------------------------------------------------------------------------- /C09/Applicative.hs: -------------------------------------------------------------------------------- 1 | import Control.Applicative 2 | class MultiFunctor f where 3 | fmap0 :: a -> f a -- 等价于可应用函子中的pure函数 4 | fmap1 :: (a -> b) -> f a -> f b -- 等价于函子类型类的fmap 5 | fmap2 :: (a -> b -> c) -> f a -> f b -> f c 6 | -- 有了前面的3个函数就可以定义任意多元的fmap函数了 7 | fmap3 :: (a -> b -> c -> d) -> f a -> f b -> f c -> f d 8 | fmap3 h x y z = fmap2 ($) (fmap2 h x y) z 9 | 10 | fmap4 :: (a -> b -> c -> d -> e) 11 | -> f a -> f b -> f c -> f d -> f e 12 | fmap4 h w x y z = fmap2 ($) (fmap3 h w x y) z 13 | 14 | fmap5 :: (a -> b -> c -> d -> e -> g) 15 | -> f a -> f b -> f c -> f d -> f e -> f g 16 | fmap5 h v w x y z = fmap2 ($) (fmap4 h v w x y) z 17 | -------------------------------------------------------------------------------- /C06/PrimeNumbers.hs: -------------------------------------------------------------------------------- 1 | factors :: Integral a => a -> [a] 2 | factors n = [x| x<- [1..n] , mod n x == 0] 3 | 4 | isPrime :: Integral a => a -> Bool 5 | isPrime n = factors n == [1,n] 6 | 7 | primes :: Integral a => a -> [a] 8 | primes n = [x| x <- [1..n], isPrime x] 9 | 10 | isPrime' :: Integral a => a -> Bool 11 | isPrime' 2 = True 12 | isPrime' p = p > 1 && (all (\n-> p `mod` n /= 0) $ takeWhile (\n->n*n <=p) [3,5..]) 13 | 14 | nextPrime :: Integer -> Integer 15 | nextPrime a | odd a = if isPrime a then a else nextPrime (a+2) 16 | | otherwise = nextPrime (a+1) 17 | 18 | sieve:: (Integral a) => [a] -> [a] 19 | sieve (p:xs) = p: sieve [x| x <- xs, x `mod` p /=0] 20 | 21 | primes' = sieve [2..] 22 | -------------------------------------------------------------------------------- /C25/classDict.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE KindSignatures, ConstraintKinds, GADTs,TypeOperators,RankNTypes #-} 2 | 3 | import Control.Category 4 | import GHC.Prim (Constraint) -- Constraint is in GHC.Types after GHC8 5 | 6 | data OrdDict a where 7 | OrdDict :: Ord a => OrdDict a 8 | 9 | data Dict (p :: Constraint) where 10 | Dict :: p => Dict p 11 | 12 | -- Sub :: (p => Dict q) -> p :- q 13 | newtype p :- q = Sub (p => Dict q) 14 | 15 | (\\) :: p => ((q => r) -> (p :- q) -> r) 16 | r \\ (Sub Dict) = r 17 | 18 | trans :: (b :- c) -> (a :- b) -> (a :- c) 19 | trans f g = Sub $ (Dict \\ f) \\ g 20 | 21 | refl :: a :- a 22 | refl = Sub Dict 23 | 24 | instance Category (:-) where 25 | id = refl 26 | (.) = trans 27 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /C09/Instance.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | {-# LANGUAGE FlexibleInstances,FlexibleContexts #-} 3 | 4 | data Shape = Circle Double | Square Double | Rectangle Double Double 5 | 6 | instance Eq Shape where 7 | (==) :: Shape -> Shape -> Bool 8 | Circle r1 == Circle r2 = r1 == r2 9 | Square l1 == Square l2 = l1 == l2 10 | Rectangle a1 b1 == Rectangle a2 b2 = a1 == a2 && b1 == b2 11 | _ == _ = False 12 | 13 | data Shape' a = Circle' a | Square' a | Rectangle' a a 14 | 15 | instance Eq (Shape' Double) -- 只需要FlexibleInstances 16 | instance Eq (a,a) => Eq (Shape' (a,a)) -- 同时需要两个扩展 17 | 18 | class MyShow a where 19 | myshow :: a -> String 20 | myshow _ = "default" 21 | 22 | data Person = P String Int 23 | instance MyShow Person -------------------------------------------------------------------------------- /C25/cat1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | import Prelude (undefined, Either (..)) 3 | 4 | (.) :: (b -> c) -> (a -> b) -> (a -> c) 5 | (.) f g x = f (g x) 6 | 7 | (*) :: (a1 -> b1) -> (a2 -> b2) -> (a1,a2) -> (b1,b2) 8 | (*) f g (a1,a2) = (f a1, g a2) 9 | 10 | (<.>) :: (a -> b) -> (a -> c) -> a -> (b,c) 11 | (<.>) f g a = (f a, g a) 12 | 13 | pi1 :: (a,b) -> a 14 | pi1 (a,b) = a 15 | 16 | pi2 :: (a,b) -> b 17 | pi2 (a,b) = b 18 | 19 | data Pair a b = Pair a b 20 | 21 | f :: Pair b c -> b 22 | f (Pair a b) = a 23 | 24 | g :: Pair b c -> c 25 | g (Pair a b) = b 26 | 27 | h :: a -> Pair b c 28 | h = undefined 29 | 30 | either :: (a -> c) -> (b -> c) -> Either a b -> c 31 | either f _ (Left x) = f x 32 | either _ g (Right y) = g y 33 | -------------------------------------------------------------------------------- /C12/MergeSort.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.Writer 2 | 3 | merge [] xs = xs 4 | merge xs [] = xs 5 | merge (x:xs) (y:ys) 6 | | x<=y = x : merge xs (y:ys) 7 | | otherwise = y: merge (x:xs) ys 8 | 9 | indent :: Int -> ShowS 10 | indent n = showString (take (4 * n) (repeat ' ')) 11 | 12 | nl :: ShowS 13 | nl = showChar '\n' 14 | 15 | mergesort :: Int -> [Int] -> Writer String [Int] 16 | mergesort l [] = return [] 17 | mergesort l s@[x] = return [x] 18 | mergesort l s@xs = do 19 | tell $ (indent l.showString "mergesort: ".shows s.nl) "" 20 | let (a1,a2) = splitAt (length s `div` 2) xs 21 | tell $ (indent (l+1).showString "merge".shows a1.shows a2.nl) "" 22 | liftM2 merge (mergesort (l+2) a1) (mergesort (l+2) a2) 23 | -------------------------------------------------------------------------------- /C11/printf.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, OverlappingInstances #-} 2 | 3 | class Printf t where 4 | printf :: String -> t 5 | 6 | instance Printf (IO ()) where 7 | printf cs = putStrLn cs 8 | 9 | format :: Show t => String -> t -> String 10 | format ('%' : 's' : cs) cs' = show cs' ++ cs 11 | format (c : cs) cs' = c : format cs cs' 12 | format "" cs' = "" 13 | 14 | instance Show t => Printf (t -> IO ()) where 15 | printf cs x = putStrLn (format cs x) 16 | 17 | instance (Show u, Printf t) => Printf (u -> t) where 18 | printf cs = \x -> printf (format cs x) 19 | 20 | test1 :: IO () 21 | test1 = printf "%s and %s are friends." "Mike" "Jane" 22 | 23 | test2 :: IO () 24 | test2 = printf "%s, %s and %s are friends." "Mike" "Jane" "Chris" -------------------------------------------------------------------------------- /C20/QuickCheck.hs: -------------------------------------------------------------------------------- 1 | -- QuickCheck.hs 2 | import Test.QuickCheck 3 | import Data.List (sort) 4 | prop_even x y = even (x+y) == (even x == even y) 5 | 6 | prop_reverseUnit x = reverse [x] == [x] 7 | 8 | prop_reverseConcat xs ys = reverse (xs ++ ys) == reverse ys ++ reverse xs 9 | 10 | prop_reverseTwice xs = (reverse.reverse) xs == xs 11 | 12 | prop_reverseMap f xs = (map f.reverse) xs == (reverse.map f) xs 13 | 14 | ordered :: Ord a => [a] -> Bool 15 | ordered [] = True 16 | ordered [x] = True 17 | ordered (x:y:xs) = x<=y && ordered (y:xs) 18 | 19 | prop_ordered xs = ordered $ sort xs 20 | 21 | prop_headMin xs = head (sort xs) == minimum xs 22 | 23 | prop_headMin' :: Ord a => [a] -> Property 24 | prop_headMin' xs = not (null xs) ==> head (sort xs) == minimum xs 25 | 26 | -------------------------------------------------------------------------------- /C13/MonadLift.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.State 2 | import Control.Monad.Trans.Maybe 3 | import Control.Monad.Trans 4 | import Data.Char 5 | import Control.Monad.Trans.Writer 6 | 7 | push :: Int -> State [Int] () 8 | push x = state $ \xs -> ((),x:xs) 9 | 10 | pushMS :: Int -> MaybeT (State [Int]) () 11 | pushMS x = lift $ push x 12 | 13 | isPasswordValid :: String -> Bool 14 | isPasswordValid s = length s >= 8 && check s 15 | where check :: String -> Bool 16 | check s = and [f s | f <- map any [isUpper, isLower, isNumber]] 17 | 18 | setPassword:: MaybeT (WriterT [String] IO) () 19 | setPassword = do 20 | liftIO $ putStrLn "Please set a password" 21 | pass <- liftIO $ getLine 22 | guard (isPasswordValid pass) 23 | lift $ tell [pass] -------------------------------------------------------------------------------- /C18/PersonValueProvider.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE OverloadedStrings, DeriveGeneric, DeriveAnyClass, DeriveDataTypeable,QuasiQuotes #-} 3 | module PersonValueProvider where 4 | import Data.Aeson 5 | import GHC.Generics 6 | import Data.String 7 | import Data.Maybe 8 | import Data.Data 9 | import Language.Haskell.TH.Quote 10 | import Language.Haskell.TH 11 | 12 | data Person = Person {name :: String , age :: Int} 13 | deriving (Show, Generic, FromJSON, Data) 14 | 15 | quoteJSONPerson :: String -> ExpQ 16 | quoteJSONPerson p = dataToExpQ (const Nothing) 17 | ((fromJust.decode.fromString) p :: Person) 18 | 19 | personJSON :: QuasiQuoter 20 | personJSON = QuasiQuoter { quoteExp = quoteJSONPerson } 21 | 22 | personJSON_file = quoteFile personJSON 23 | -------------------------------------------------------------------------------- /C13/Transformer2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | import Control.Monad 3 | import Data.Functor.Identity 4 | --newtype State s a = State { runState :: s -> (s,a) } 5 | newtype StateT s m a = StateT { runStateT :: s -> m (a,s) } deriving Functor 6 | 7 | instance (Monad m) => Monad (StateT s m) where 8 | return a = StateT $ \s -> return (a, s) 9 | m >>= k = StateT $ \s -> do 10 | (a, s') <- (runStateT m) s 11 | runStateT (k a) s' 12 | 13 | instance (Monad m) => Applicative (StateT s m) where 14 | pure = return 15 | (<*>) = ap 16 | 17 | type State s a = StateT s Identity a 18 | 19 | push :: Int -> State [Int] () 20 | push x = StateT $ \xs -> Identity ((), x:xs) 21 | 22 | pop :: State [Int] Int 23 | pop = StateT $ \(x:xs) -> Identity (x,xs) -------------------------------------------------------------------------------- /C25/falg.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | 3 | type Algebra f a = f a -> a 4 | 5 | newtype Fix f = In { unFix :: f (Fix f) } 6 | 7 | cata :: (Functor f) => Algebra f a -> Fix f -> a 8 | cata f = f . fmap (cata f) . unFix 9 | 10 | data ListF a s = NilF | ConsF a s deriving Functor 11 | 12 | data List a = Nil | Cons a (List a) deriving Functor 13 | 14 | lenAlg :: ListF a Int -> Int 15 | lenAlg NilF = 0 16 | lenAlg (ConsF a n) = 1 + n 17 | 18 | muList :: List a -> Fix (ListF a) 19 | muList Nil = In NilF 20 | muList (Cons a xs) = In (ConsF a (muList xs)) 21 | 22 | toList :: Fix (ListF a) -> List a 23 | toList (In NilF) = Nil 24 | toList (In (ConsF a xs)) = Cons a (toList xs) 25 | 26 | len :: List a -> Int 27 | len = cata lenAlg . muList 28 | 29 | foldr :: Algebra f a -> [a] -> b 30 | foldr = undefined -- 31 | -------------------------------------------------------------------------------- /C21/TemplateRemoteSpawn.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Main where 4 | 5 | import Control.Distributed.Process 6 | import Control.Distributed.Process.Node (initRemoteTable, runProcess) 7 | import Control.Distributed.Process.Closure 8 | import Control.Distributed.Process.Backend.SimpleLocalnet 9 | 10 | foo :: SendPort String -> Process String 11 | foo sp = do 12 | sendChan sp "World" 13 | return "Hello " 14 | 15 | remotable ['foo] 16 | 17 | main :: IO () 18 | main = do 19 | backend <- initializeBackend "localhost" "2000" $ __remoteTable initRemoteTable 20 | node <- newLocalNode backend 21 | runProcess node $ do 22 | nid <- getSelfNode 23 | (sp, rp) <- newChan 24 | res1 <- call $(functionTDict 'foo) nid ($(mkClosure 'foo) sp) 25 | res2 <- receiveChan rp 26 | liftIO (putStrLn $ res1 ++ res2) 27 | -------------------------------------------------------------------------------- /C10/Maybe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | import Prelude hiding (Maybe, Just, Nothing) 3 | 4 | data Identity a = Identity a 5 | data Maybe a = Just a | Nothing deriving Functor 6 | 7 | instance Applicative Maybe where 8 | pure = Just 9 | Just f <*> Just a = Just (f a) 10 | _ <*> _ = Nothing 11 | 12 | instance Monad Maybe where 13 | return = Just 14 | (Just a) >>= f = f a 15 | Nothing >>= _ = Nothing 16 | fail _ = Nothing 17 | 18 | data Exp = Lit Integer 19 | | Add Exp Exp 20 | | Sub Exp Exp 21 | | Mul Exp Exp 22 | | Div Exp Exp 23 | deriving (Show) 24 | 25 | safeEval (Add e1 e2) = do 26 | n1 <- safeEval e1 27 | n2 <- safeEval e2 28 | return (n1+n2) 29 | -------------------------------------------------------------------------------- /C25/cat0.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds, DataKinds,KindSignatures,PolyKinds,TypeFamilies #-} 2 | import Data.Constraint 3 | 4 | class Category (cat :: k -> k -> *) where 5 | type Object cat (a :: k) :: Constraint 6 | id :: Object cat a => cat a a 7 | (.) :: (Object cat a, Object cat b, Object cat c) => 8 | cat b c -> cat a b -> cat a c 9 | 10 | instance Category (->) where 11 | type Object (->) (a :: *) = () 12 | id x = x 13 | (.) g f x = g (f x) 14 | 15 | data Void 16 | data Unit = Unit 17 | 18 | absurd :: Void -> a 19 | absurd = absurd 20 | 21 | unit :: a -> Unit 22 | unit _ = Unit 23 | 24 | data V 25 | data U = U 26 | 27 | vphi :: V -> Void 28 | vphi = vphi 29 | 30 | vpsy :: Void -> V 31 | vpsy = absurd 32 | 33 | uphi :: U -> Unit 34 | uphi U = Unit 35 | 36 | upsy :: Unit -> U 37 | upsy Unit = U 38 | -------------------------------------------------------------------------------- /C09/TraversableTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable,DeriveFunctor #-} 2 | data Tree a = Leaf a | Node (Tree a) a (Tree a) 3 | deriving (Show,Foldable,Functor) 4 | 5 | instance Traversable Tree where 6 | -- traverse :: Applicative f => (a -> f b) -> Tree a -> f (Tree b) 7 | traverse f (Leaf a) = Leaf <$> f a 8 | traverse f (Node l a r) = Node <$> traverse f l <*> f a <*> traverse f r 9 | -- sequenceA :: Applicative f => Tree (f a) -> f (Tree a) 10 | sequenceA (Leaf a) = Leaf <$> a 11 | sequenceA (Node l a r) = Node <$> (sequenceA l) <*> a <*> (sequenceA r) 12 | 13 | tree0,tree1 :: Tree Double 14 | tree0 = (Node (Leaf 0) 1 (Leaf 2)) 15 | tree1 = (Node (Leaf 1) 2 (Leaf 3)) 16 | 17 | reciprocal :: (Eq b, Fractional b, Traversable t) => t b -> Maybe (t b) 18 | reciprocal = traverse (\x -> if x == 0 then Nothing else Just (1/x)) 19 | -------------------------------------------------------------------------------- /C06/EightQueens.hs: -------------------------------------------------------------------------------- 1 | -- EightQueens.hs 2 | import Data.List (permutations) 3 | positions 0 n = [[]] 4 | positions k n = [x:xs| x <- [1..n], xs <- positions (k-1) n] 5 | 6 | noSameRow [] = True 7 | noSameRow (x:xs) = (not $ elem x xs) && noSameRow xs 8 | 9 | noSameDiag [] = True 10 | noSameDiag xs@(x:xs') = and [abs (i1-i)/=abs (p1-p)|(i,p)<-ip] && noSameDiag xs' 11 | where (i1,p1):ip = zip [1..] xs 12 | 13 | queen n = [xs| xs <- positions n n, noSameRow xs, noSameDiag xs] 14 | 15 | positions' 0 n = [[]] 16 | positions' k n = [p:ps| ps<-positions' (k-1) n,p <- [1..n], isSafe p ps] 17 | 18 | isSafe p ps = not ((elem p ps) || (sameDiag p ps)) 19 | where sameDiag p ps = any (\(dist,q) -> abs (p-q)==dist) $ zip [1..] ps 20 | 21 | queens = positions' 8 8 22 | 23 | queens' :: Int -> [[Int]] 24 | queens' n = [xs| xs <- permutations [1..n], noSameDiag xs] -------------------------------------------------------------------------------- /C14/ConduitPi.hs: -------------------------------------------------------------------------------- 1 | import Data.Conduit 2 | import qualified Data.Conduit.List as CL 3 | import System.Random 4 | import Control.Monad.IO.Class 5 | import Control.Monad 6 | import Control.Monad.Trans 7 | randomCL :: MonadIO m => Producer m Double 8 | randomCL = forever $ do 9 | a <- liftIO (randomIO :: IO Double) 10 | yield a 11 | 12 | square :: Monad m => Conduit Double m Int 13 | square = forever $ do 14 | mx <- await 15 | my <- await 16 | case ((\x y -> (x-0.5) ^ 2 + (y-0.5) ^2) <$> mx <*> my) of 17 | Just a -> yield $ if (a <= 0.25) then 1 else 0 18 | Nothing -> return () 19 | 20 | times = 1500 :: Int 21 | 22 | cpi :: IO Int 23 | cpi = runConduit $ randomCL $= square $= CL.isolate times $= CL.fold (+) 0 24 | 25 | main :: IO () 26 | main = do 27 | as <- cpi 28 | print $ fromIntegral as / fromIntegral times * 4 29 | -------------------------------------------------------------------------------- /C08/Zipper.hs: -------------------------------------------------------------------------------- 1 | data Zipper a = Zipper [a] a [a] deriving Show 2 | 3 | fromList :: [a] -> Zipper a 4 | fromList (x:xs) = Zipper [] x xs 5 | fromList _ = error "empty!" 6 | 7 | next :: Zipper a -> Zipper a 8 | next (Zipper ys y (x:xs)) = Zipper (y:ys) x xs 9 | next z = z 10 | 11 | prev :: Zipper a -> Zipper a 12 | prev (Zipper (y:ys) x xs) = Zipper ys y (x:xs) 13 | prev z = z 14 | 15 | data Tree a = Leaf a | Node a (Tree a) (Tree a) 16 | data Accumulate a = Empty | L (Accumulate a) a (Tree a) 17 | | R (Accumulate a) a (Tree a) 18 | 19 | 20 | type Zipper a = (Tree a, Accumulate a) 21 | 22 | right,left,up :: Zipper a -> Zipper a 23 | right (Node n l r, a) = (r, R a n l) 24 | right a = a 25 | 26 | left (Node n l r, a) = (l, L a n r) 27 | left a = a 28 | 29 | up (t, R a n l) = (Node n l t, a) 30 | up (t, L a n r) = (Node n t r, a) 31 | up z@(t, Empty )= z -------------------------------------------------------------------------------- /C16/SplitClasses.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances,UndecidableInstances,DataKinds,MultiParamTypeClasses,KindSignatures,TypeFamilies, ScopedTypeVariables #-} 2 | import Data.Proxy 3 | class PlusPrint a where 4 | test :: a -> IO () 5 | 6 | data NumType = Ints | Reals 7 | 8 | type family GetNumType (a :: *) :: NumType where 9 | GetNumType Int = Ints 10 | GetNumType Integer = Ints 11 | GetNumType Double = Reals 12 | GetNumType Float = Reals 13 | 14 | class PlusPrint' (flag :: NumType) a where 15 | test' :: Proxy flag -> a -> IO () 16 | 17 | instance (Integral a, Show a) => PlusPrint' Ints a where 18 | test' _ a = print $ a + 1 19 | 20 | instance (RealFloat a, Show a) => PlusPrint' Reals a where 21 | test' _ a = print $ a + 2 22 | 23 | instance (GetNumType a ~ flag , PlusPrint' flag a) => PlusPrint a where 24 | test a = test' (Proxy :: Proxy flag) a 25 | 26 | 27 | -------------------------------------------------------------------------------- /C20/SmallCheck.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DeriveGeneric #-} 2 | 3 | import Test.SmallCheck 4 | import Test.SmallCheck.Series 5 | 6 | import GHC.Generics 7 | import Data.Functor.Identity 8 | 9 | data Exp = Val Bool 10 | | And Exp Exp 11 | | Or Exp Exp 12 | deriving (Show, Eq, Generic) 13 | 14 | eval :: Exp -> Bool 15 | eval (Val b) = b 16 | eval (And a b) = eval a && eval b 17 | eval (Or a b) = eval a || eval b 18 | 19 | instance Monad m => Serial m Exp 20 | 21 | prop_1 :: Monad m => Property m 22 | prop_1 = forAll $ \x -> eval x == True || eval x == False 23 | 24 | x6 :: Monad m => Property m 25 | x6 = existsUnique $ \x -> (x - 6) > (0 :: Int) 26 | 27 | prop_assoc :: Monad m => Property m 28 | prop_assoc = forAll $ \ x y z -> ((x + y) + z) == (x + (y + (z :: Int))) 29 | 30 | prop_assoc1 :: Monad m => Property m 31 | prop_assoc1 = forAll $ \ x y z -> ((x + y) + z) == (x + (y - (z::Int))) 32 | -------------------------------------------------------------------------------- /C09/TraversableTest2.hs: -------------------------------------------------------------------------------- 1 | import Data.Functor.Identity 2 | import Data.Functor.Constant 3 | -- import Data.Traversable 4 | 5 | fmap' :: Traversable t => (a -> b) -> t a -> t b 6 | fmap' f x = runIdentity $ traverse (Identity . f) x 7 | 8 | foldMap' :: (Traversable t, Monoid m) => (a -> m) -> t a -> m 9 | foldMap' f x = getConstant $ traverse (Constant . f) x 10 | 11 | newtype Const a b = Const {getConst :: a} 12 | 13 | instance Functor (Const a) where 14 | fmap f (Const x) = Const x 15 | 16 | instance (Monoid a) => Applicative (Const a) where 17 | pure _ = Const mempty 18 | Const x <*> Const y = Const (x `mappend` y) 19 | 20 | instance Foldable (Const a) where 21 | -- foldMap :: Monoid a => (a -> m) -> Const a1 a -> m 22 | foldMap f (Const x) = mempty 23 | 24 | 25 | instance Traversable (Const a) where 26 | -- traverse :: Applicative f => (a1 -> f b) -> Const a a1 -> f (Const a b) 27 | traverse f (Const x) = pure (Const x) -------------------------------------------------------------------------------- /C18/aeson.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric,TemplateHaskell,OverloadedStrings #-} 2 | 3 | import GHC.Generics 4 | import Data.Aeson 5 | import Data.Char 6 | import Data.Aeson.TH 7 | 8 | data Recipe = Recipe 9 | { reciName :: String 10 | , reciIngredients :: [Ingredient] 11 | } deriving (Show, Eq, Generic) 12 | 13 | data Ingredient = Ingredient 14 | { ingrName :: String 15 | , ingrQuantity :: Int 16 | , ingrMeasure :: Maybe String 17 | } deriving (Show, Eq,Generic) 18 | 19 | (deriveJSON defaultOptions{fieldLabelModifier = 20 | (map toLower).(drop 4)} ''Recipe) 21 | 22 | (deriveJSON defaultOptions{fieldLabelModifier = 23 | (map toLower).(drop 4)} ''Ingredient) 24 | 25 | cake :: Ingredient 26 | cake = Ingredient { ingrName = "Ciambellone Cake", 27 | ingrQuantity = 250, 28 | ingrMeasure = Just "gram"} 29 | -------------------------------------------------------------------------------- /C25/cat3.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE KindSignatures #-} 2 | {-# LANGUAGE FlexibleInstances,UndecidableInstances #-} 3 | 4 | import Prelude hiding (Applicative , pure , (<*>), (**)) 5 | class Functor f => Applicative (f :: * -> *) where 6 | pure :: a -> f a 7 | (<*>) :: f (a -> b) -> f a -> f b 8 | 9 | (***) :: (a -> b) -> (c -> d) -> (a, c) -> (b, d) 10 | f *** g = \(x,y) -> (f x, g y) 11 | 12 | instance LaxMonoidal f => Applicative f where 13 | pure x = fmap (\() -> x) unit 14 | -- 先得到f (a -> b, a)，再通过(\$)应用二元组中a -> b的函数到a 15 | f <*> x = fmap (uncurry ($)) (f ** x) 16 | 17 | instance Applicative f => LaxMonoidal f where 18 | unit = pure () 19 | -- fmap (,) :: Functor f => f a ~> f (b -> (a, b)) 20 | -- fmap (,) a :: Functor f => f (b -> (a, b)) 21 | a ** b = (fmap (,) a) <*> b 22 | 23 | class Functor f => LaxMonoidal f where 24 | unit :: f () -- 对应 $i$ 25 | (**) :: f a -> f b -> f (a,b) -- 对应$\phi$，等价于(f a, f b) -> f (a,b) 26 | -------------------------------------------------------------------------------- /C24/ContinuationFRPTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | 3 | import BouncingBall 4 | import ContinuationFRP 5 | import Control.Arrow 6 | 7 | fallingBall :: Ball -> SF a Ball 8 | fallingBall (h0,v0) = proc _ -> do 9 | v <- integral v0 -< -g 10 | h <- integral h0 -< v 11 | returnA -< (h,v) 12 | 13 | detectBounce :: SF Ball (Event Ball) 14 | detectBounce = edge detectImpact 15 | 16 | inelasticBall :: Ball -> SF a Ball 17 | inelasticBall b = switch (fallingBall b) detectBounce (\_ -> constant (0,0)) 18 | 19 | elasticBall :: Ball -> SF a Ball 20 | elasticBall b = switch (fallingBall b) detectBounce (\(h,v) -> if abs v < 0.1 21 | then constant (0,0) 22 | else elasticBall (0, (negate v)*0.6)) 23 | 24 | -- reactimate (return ()) (return 0.001) (\(h,v) -> h == 0) print (elasticBall (10,0)) 25 | -------------------------------------------------------------------------------- /C14/IterateeTest.hs: -------------------------------------------------------------------------------- 1 | import qualified Data.Iteratee as I 2 | import Data.Iteratee.Iteratee (($=),(=$),mapChunks, enumPure1Chunk) 3 | import Data.Iteratee.IO 4 | import qualified Data.ByteString as DB 5 | import Data.ByteString (ByteString) 6 | import Data.ListLike hiding (map) 7 | import Control.Monad 8 | import Data.Char 9 | 10 | -- alternative :: I.Iteratee 11 | drop1keep1 :: (I.Nullable s, ListLike s el, Monad m) => I.Iteratee s m el 12 | drop1keep1 = I.drop 1 >> I.head 13 | 14 | alternatives :: (I.Nullable s, ListLike s el, Monad m) => I.Iteratee s m [el] 15 | alternatives = replicateM 5 drop1keep1 16 | 17 | -- > I.enumPure1Chunk [1..10] alternatives >>= I.run 18 | 19 | byteCounter :: Monad m => I.Iteratee ByteString m Int 20 | byteCounter = I.length 21 | 22 | countBytes = do 23 | i' <- (enumFile 8192 "Wreq.hs" >=> enumFile 8192 "Wreq.hs") byteCounter 24 | result <- I.run i' 25 | print result 26 | 27 | -- > (I.enumPure1Chunk [1..100] $= I.take 10) alternatives >>= I.run 28 | 29 | -------------------------------------------------------------------------------- /C07/Fold.hs: -------------------------------------------------------------------------------- 1 | -- Fold.hs 2 | (+++) :: [a] -> [a] -> [a] 3 | (+++) = foldr (:) 4 | 5 | insert :: Ord a => a -> [a] -> [a] 6 | insert x [] = [x] 7 | insert x (y:ys) | x < y = x : y: ys 8 | | otherwise = y:insert x ys 9 | 10 | isort :: Ord a => [a] -> [a] 11 | isort xs = foldr insert [] xs 12 | 13 | skip :: Eq a => a -> [a] -> [a] 14 | skip x [] = [x] 15 | skip x (y:ys) | x == y = (y:ys) 16 | | otherwise = x:y:ys 17 | 18 | compress :: Eq a => [a] -> [a] 19 | compress = foldr skip [] 20 | 21 | snoc :: a -> [a] -> [a] 22 | snoc x = foldr (:) [x] 23 | 24 | concat :: [[a]] -> [a] 25 | concat = foldr (++) [] 26 | 27 | map' :: (a -> b) -> [a] -> [b] 28 | map' f = foldr (\l ls -> f l : ls) [] 29 | 30 | reverse' :: [a] -> [a] 31 | reverse' = foldl (flip (:)) [] 32 | 33 | unwords' :: [String] -> String 34 | unwords' [] = "" 35 | unwords' ws = foldr1 (\w s -> w ++ ' ':s) ws 36 | 37 | maximum', minimum' :: Ord a => [a] -> a 38 | maximum' = foldl1 max 39 | minimum' = foldl1 min -------------------------------------------------------------------------------- /C12/MWC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | import qualified Data.Vector.Unboxed as U 3 | import System.Random.MWC 4 | import Control.Monad.ST 5 | import Control.DeepSeq 6 | import System.Random 7 | 8 | random' :: Int -> IO (U.Vector Double) 9 | random' n = do 10 | g <- newStdGen 11 | return $ U.fromList (take n (randoms g)) 12 | 13 | random'' :: Int -> IO (U.Vector Double) 14 | random'' n = do 15 | vs <- withSystemRandom $ 16 | \(gen::GenST s) -> uniformVector gen n :: ST s (U.Vector Double) 17 | return $ U.force (vs :: (U.Vector Double)) 18 | 19 | getPiV :: IO Double 20 | getPiV = do 21 | xs <- random' 6000 22 | ys <- random' 6000 23 | let isIn = U.zipWith (\x y -> if (x-0.5)^2 + (y-0.5)^2 <= 0.25 24 | then 1.0 else 0) xs ys 25 | return $ (4.0 :: Double) * (force (U.sum isIn)) / (6000 :: Double) 26 | 27 | main = do 28 | ps <- U.forM (U.fromList [1..2000 :: Int]) (\i -> getPiV) 29 | putStrLn . show $ force $ U.sum ps / (2000 :: Double) 30 | -------------------------------------------------------------------------------- /C13/MonadOrder2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | import Control.Monad 3 | import Control.Monad.State 4 | import Control.Monad.Writer 5 | 6 | pushWS :: Int -> WriterT String (State [Int]) () 7 | pushWS x = WriterT $ state $ \xs -> ((()," push "++ show x),x:xs) 8 | 9 | popWS :: WriterT String (State [Int]) Int 10 | popWS = WriterT $ state $ \(x:xs) -> ((x," pop "++ show x),xs) 11 | 12 | push :: Int -> StateT [Int] (Writer String) () 13 | push x = StateT $ \xs -> writer (((),x:xs), " push "++ show x) 14 | 15 | pop :: StateT [Int] (Writer String) Int 16 | pop = StateT $ \(x:xs) -> writer ((x,xs), " pop" ++ show x) 17 | 18 | newtype WS s w a = WS {runWS::s -> (a, s ,w)} deriving Functor 19 | instance Monoid w => Monad (WS s w) where 20 | return a = WS $ \s -> (a, s, mempty) 21 | k >>= f = WS $ \s -> 22 | let (a, s', m) = runWS k s 23 | (r, ns, m') = runWS (f a) s' 24 | in (r, ns, m `mappend` m') 25 | 26 | instance Monoid w => Applicative (WS s w) where 27 | pure = return 28 | (<*>) = ap 29 | -------------------------------------------------------------------------------- /C17/SYBBinary.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable,RankNTypes #-} 2 | import Data.Binary 3 | import Data.Data 4 | import Data.Word 5 | 6 | myput :: Data a => a -> Put 7 | myput a = let i = (fromIntegral $ constrIndex $ toConstr a) - 1 :: Word8 8 | in if isAlgType (dataTypeOf a) 9 | then foldl (>>) (put i) (gmapQ myput a) 10 | else error "not algebric data type" 11 | 12 | getCallBack :: Data a => (forall d.Data d => Get d) -> Get a 13 | getCallBack c = generalCase 14 | where 15 | dataType = dataTypeOf ((undefined :: Get b -> b) generalCase) 16 | generalCase = let index = getWord8 >>= return . fromIntegral 17 | in if isAlgType dataType 18 | then index >>= \i -> fromConstrM c (indexConstr dataType (i + 1)) 19 | else error "not algebric data type" 20 | 21 | myget :: Data a => Get a 22 | myget = getCallBack myget 23 | 24 | data A = A Bool | B [Bool] deriving (Show, Data, Typeable) 25 | 26 | instance Binary A where 27 | put = myput 28 | get = myget 29 | -------------------------------------------------------------------------------- /C21/Async.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Main where 4 | 5 | import Control.Monad 6 | 7 | import Control.Distributed.Process 8 | import Control.Distributed.Process.Closure 9 | import Control.Distributed.Process.Node (initRemoteTable, runProcess) 10 | import Control.Distributed.Process.Backend.SimpleLocalnet 11 | import Control.Distributed.Process.Async 12 | 13 | doTask :: (Double, Double) -> Process Double 14 | doTask (n, d) = do 15 | when (d == 0) $ die "Task failed!" 16 | return (n / d) 17 | 18 | remotable ['doTask] 19 | 20 | mainProcess :: Process () 21 | mainProcess = do 22 | nid <- getSelfNode 23 | let createTask :: Double -> Double -> AsyncTask Double 24 | createTask n d = 25 | remoteTask $(functionTDict 'doTask) nid ($(mkClosure 'doTask) (n, d)) 26 | h1 <- asyncLinked $ createTask 1 2 27 | h2 <- asyncLinked $ createTask 2 0 28 | AsyncDone 0.5 <- wait h1 29 | AsyncFailed _ <- wait h2 30 | return () 31 | 32 | main :: IO () 33 | main = do 34 | backend <- initializeBackend "localhost" "2000" $ __remoteTable initRemoteTable 35 | node <- newLocalNode backend 36 | runProcess node mainProcess 37 | -------------------------------------------------------------------------------- /C22/myhaskell/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Empty 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /C13/MonadComp.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.State 2 | import Control.Monad.Trans.Maybe 3 | 4 | push :: Int -> State [Int] () 5 | push x = state $ \xs -> ((),x:xs) 6 | 7 | pop :: State [Int] (Maybe Int) 8 | pop = state $ \xs -> case xs of 9 | [] -> (Nothing,[]) 10 | (x:xs) -> (Just x, xs) 11 | 12 | stack :: State [Int] () 13 | stack = do 14 | push 5 15 | pop 16 | pop 17 | push 4 18 | 19 | stack1 :: State [Int] (Maybe Int) 20 | stack1 = do 21 | push 5 22 | a<-pop 23 | case a of 24 | Nothing -> return Nothing 25 | Just a -> return (Just (a+1)) 26 | 27 | stackMS1 :: MaybeT (State [Int]) Int 28 | stackMS1 = do 29 | pushMS 5 30 | i <- popMS 31 | return (i+1) 32 | 33 | pushMS :: Int -> MaybeT (State [Int]) () 34 | pushMS x = MaybeT $ state $ \xs -> (Just (),x:xs) 35 | 36 | popMS :: MaybeT (State [Int]) Int 37 | popMS = MaybeT $ state $ \xs -> case xs of 38 | [] -> (Nothing, xs) 39 | (y:ys) -> (Just y, ys) 40 | -------------------------------------------------------------------------------- /C05/Fib.hs: -------------------------------------------------------------------------------- 1 | -- Fib.hs 2 | fibonacci :: (Num a, Eq a) => a -> a 3 | fibonacci 0 = 0 4 | fibonacci 1 = 1 5 | fibonacci n = fibonacci (n-1) + fibonacci (n-2) 6 | 7 | fibs n = map fibonacci [0..n] 8 | 9 | fibStep :: Num a => (a, a) -> (a, a) 10 | fibStep (u,v) = (v,u+v) 11 | 12 | fibPair :: (Eq a, Num a) => a -> (a, a) 13 | fibPair 0 = (0,1) 14 | fibPair n = fibStep (fibPair (n-1)) 15 | 16 | fastFib :: (Eq b, Num b) => b -> b 17 | fastFib n = fst (fibPair n) 18 | 19 | {- 20 | fibs :: (Enum b, Eq b, Num b) => b -> [b] 21 | fibs n = map fastFib [1..n] 22 | -} 23 | 24 | fibs' n = take n (map fst (iterate fibStep (0,1))) 25 | 26 | fib 0 f1 f2 = f2 27 | fib n f1 f2 = fib (n-1) f2 (f1+f2) 28 | 29 | fibonacci' n = fib n 1 1 30 | 31 | golden :: Fractional a => Int -> [a] 32 | golden n = take n (map (\(x,y) -> x/y) (iterate fibStep (0,1))) 33 | 34 | combine :: [(a,a)] -> [(a,a,a)] 35 | combine ((f1,f2):(f3,f4):fs) = (f1,f2,f4):combine ((f3,f4):fs) 36 | combine _ = [] 37 | 38 | fibPairs :: Int -> [(Int,Int)] 39 | fibPairs n = map fibPair [1..n] 40 | 41 | difference :: Int -> [Int] 42 | difference n = map (\(f1,f2,f3)->f1*f3-f2*f2) (combine $ fibPairs n) 43 | -------------------------------------------------------------------------------- /C14/FreeMonad1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, KindSignatures #-} 2 | import Control.Monad 3 | import Control.Monad.State 4 | 5 | data Interaction :: * -> * where 6 | Say :: String -> Interaction () 7 | Ask :: Interaction String 8 | Return :: a -> Interaction a 9 | Bind :: Interaction a -> (a -> Interaction b) -> Interaction b 10 | 11 | instance Functor Interaction 12 | 13 | instance Applicative Interaction where 14 | pure = return 15 | (<*>) = ap 16 | 17 | instance Monad Interaction where 18 | return = Return 19 | (>>=) = Bind 20 | 21 | say = Say 22 | ask = Ask 23 | 24 | test1 = do 25 | say "who are you" 26 | a <- ask 27 | say $ "hello " ++ a 28 | 29 | run1 :: Interaction a -> IO a 30 | run1 (Say msg) = putStrLn msg 31 | run1 Ask = getLine 32 | run1 (Return x) = return x 33 | run1 (Bind m f) = do x <- run1 m ; run1 (f x) 34 | 35 | type Output = [String] 36 | type Input = [String] 37 | 38 | run2 :: Interaction a -> State (Input, Output) a 39 | run2 (Say msg) = state $ \(input, write) -> ((), (input, write ++ [msg])) 40 | run2 Ask = state $ \(i:is, write) -> (i , (is, write)) 41 | run2 (Return x) = return x 42 | run2 (Bind m f) = do x <- run2 m ; run2 (f x) 43 | -------------------------------------------------------------------------------- /C24/BouncingBall.hs: -------------------------------------------------------------------------------- 1 | module BouncingBall where 2 | 3 | type Acceleration = Double 4 | type Velocity = Double 5 | type Height = Double 6 | 7 | type Ball = (Height, Velocity) 8 | 9 | g :: Acceleration 10 | g = 9.81 11 | 12 | detectImpact :: Ball -> Bool 13 | detectImpact (h , v) = h <= 0 14 | 15 | negateVel :: Ball -> Ball 16 | negateVel (h , v) = (h , negate v) 17 | 18 | detectBounce :: SF (Double, t) (Event (Double, t)) 19 | detectBounce = when (\(pos , v) -> pos <= 0) 20 | 21 | elasticBall :: Ball -> SF () Ball 22 | elasticBall (p, v) = rswitchWhen (fallingBall (p, v)) 23 | detectBounce (fallingBall . \(p',v') -> (p',negate v')) 24 | 25 | rswitchWhen :: SF a b -> SF b (Event c) -> (c -> SF a b) -> SF a b 26 | rswitchWhen sf sfe f = rswitch (sf >>> forkSecond sfe) 27 | (\e -> f e >>> forkSecond sfe) 28 | 29 | rswitch :: SF a (b, Event c) -> (c -> SF a (b, Event c)) -> SF a b 30 | rswitch sf f = switch sf (\e -> rswitch (f e >>> sfSecond notYet) f) 31 | 32 | forkSecond :: SF a c' -> SF a (a, c') 33 | forkSecond sf = sfFork >>> sfSecond sf 34 | 35 | sfSecond sf = identity *** sf 36 | 37 | sfFork = arr fork 38 | 39 | fork a = (a,a) 40 | -------------------------------------------------------------------------------- /C13/Parser.hs: -------------------------------------------------------------------------------- 1 | -- Parser.hs 2 | import Control.Applicative 3 | import Control.Monad 4 | import Control.Monad.State 5 | import Control.Monad.Trans.Maybe 6 | import Data.Char 7 | 8 | data Node = Tag String [Node] 9 | | Text String 10 | deriving (Show,Eq) 11 | 12 | xml :: String 13 | xml = "Hello world!Hello again!" 14 | 15 | type Parser a = StateT String Maybe a 16 | 17 | satisfy :: (Char -> Bool) -> Parser Char 18 | satisfy p = StateT $ \str -> case str of 19 | [] -> Nothing 20 | s:ss -> if p s then Just (s,ss) else Nothing 21 | char :: Char -> Parser Char 22 | char c = satisfy (==c) 23 | 24 | letter = satisfy isAlpha 25 | string str = mapM char str 26 | 27 | 28 | runParser :: Parser a -> String -> Maybe (a, String) 29 | runParser = runStateT 30 | 31 | textNode :: Parser Node 32 | textNode = fmap Text $ some $ satisfy (/='<') 33 | 34 | tagNode :: Parser Node 35 | tagNode = do 36 | tagName <- char '<' *> many letter <* char '>' 37 | subNode <- many $ tagNode <|> textNode 38 | string "> string tagName >> char '>' 39 | return $ Tag tagName subNode 40 | -------------------------------------------------------------------------------- /C04/chapter04.hs: -------------------------------------------------------------------------------- 1 | import Data.List (genericLength) 2 | 3 | avg xs = sum xs / genericLength xs 4 | 5 | elem' :: Eq a => a -> [a] -> Bool 6 | elem' a xs = not $ null (filter (==a) xs) 7 | 8 | type Weekday = Int 9 | type Year = Int 10 | type Month = Int 11 | type Day = Int 12 | 13 | week' :: Year -> Day -> Weekday 14 | week' y d = let y1 = y - 1 in 15 | (y1 + (div y1 4) - (div y1 100) + (div y1 400) + d) `mod` 7 16 | 17 | isLeapYear :: Int -> Bool 18 | isLeapYear y = (mod y 4 == 0) && (mod y 100 /= 0) || (mod y 400 == 0) 19 | 20 | monthDays :: Year -> Month -> Int 21 | monthDays y m | m == 2 = if not $ isLeapYear y then 28 else 29 22 | | elem m [1,3,5,7,8,10,12] = 31 23 | | elem m [4,6,9,11] = 30 24 | | otherwise = error "invaid month" 25 | 26 | accDays :: Year -> Month -> Day -> Int 27 | accDays y m d | d > monthDays y m = error "invalid days" 28 | | otherwise =(sum $ take (m-1) (map (monthDays y) [1..12]))+d 29 | 30 | week y m d = week' y (accDays y m d) 31 | 32 | contains6':: [Int] 33 | contains6' = map (\str->read str::Int) $ filter (elem '6') (map show [1..100]) 34 | 35 | -------------------------------------------------------------------------------- /C12/Reader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,FlexibleInstances #-} 3 | 4 | import Control.Monad 5 | 6 | newtype Reader r a = Reader { runReader :: r -> a } 7 | deriving Functor 8 | 9 | instance Monad (Reader r) where 10 | return a = Reader $ \_ -> a 11 | m >>= k = Reader $ \r -> runReader (k (runReader m r)) r 12 | 13 | instance Applicative (Reader r) where 14 | pure = return 15 | (<*>) = ap 16 | 17 | readLen :: Reader [a] Int 18 | readLen = Reader $ \r -> length r 19 | 20 | class (Monad m) => MonadReader r m | m -> r where 21 | ask :: m r 22 | local :: (r -> r) -> m a -> m a 23 | 24 | instance MonadReader r (Reader r) where 25 | ask = Reader id 26 | local f m = Reader $ runReader m . f 27 | 28 | test :: Reader [Int] [Int] 29 | test = do 30 | xs <- local (map (+1)) ask 31 | ys <- ask 32 | return ys 33 | 34 | withReader :: (r' -> r) -> Reader r a -> Reader r' a 35 | withReader f m = Reader $ runReader m . f 36 | 37 | mapReader :: (a -> b) -> Reader r a -> Reader r b 38 | mapReader f m = Reader $ f . runReader m -------------------------------------------------------------------------------- /C18/TypeArity.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, PolyKinds #-} 2 | module TypeArity where 3 | import Data.Proxy 4 | import Language.Haskell.TH 5 | 6 | class TypeArity (cla :: k) where 7 | arity :: Proxy cla -> Integer 8 | 9 | getTypeArity :: Name -> Q Int 10 | getTypeArity name = do 11 | info <- reify name 12 | case info of 13 | TyConI dec -> 14 | case dec of 15 | DataD _ _ tvbs cons _ -> return $ length tvbs 16 | NewtypeD _ _ tvbs con _ -> return $ length tvbs 17 | _ -> error "The type must be data, newtype definition!" 18 | _ -> error "bad type name, quoted name is not a type!" 19 | 20 | makeTypeArity :: Name -> Q [Dec] 21 | makeTypeArity name = do 22 | at <- getTypeArity name 23 | let fName = mkName "arity" 24 | let fun = [FunD fName [Clause [WildP] 25 | (NormalB (LitE (IntegerL (fromIntegral at)))) 26 | []]] 27 | return $ [InstanceD [] (AppT (ConT ''TypeArity) (ConT name)) fun] 28 | 29 | {-# 30 | makeTypeArity :: Name -> Q [Dec] 31 | makeTypeArity name = do 32 | at <- getTypeArity name 33 | [d| instance TypeArity $(conT name) where 34 | arity _ = at |] 35 | #-} -------------------------------------------------------------------------------- /C23/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts,UndecidableInstances #-} 2 | 3 | 4 | import Control.Arrow 5 | import qualified Control.Category as Cat 6 | import Data.List (union) 7 | 8 | data StaticParser s = SP Bool [s] 9 | newtype DynamicParser s a b = DP {runDP :: (a, [s]) -> (b, [s])} 10 | data Parser s a b = P {static :: (StaticParser s) 11 | ,dynamic :: (DynamicParser s a b)} 12 | 13 | spCharA :: Char -> StaticParser Char 14 | spCharA c = SP False [c] 15 | 16 | dpCharA :: Char -> DynamicParser Char Char Char 17 | dpCharA c = DP (\(_,x:xs) -> (x,xs)) 18 | 19 | charA :: Char -> Parser Char Char Char 20 | charA c = P (SP False [c]) (DP (\(_,x:xs) -> (x,xs))) 21 | 22 | instance Eq s => Cat.Category (Parser s) where 23 | id = P (SP True []) (DP (\(b,s) -> (b,s))) 24 | (P (SP empty1 start1) (DP p2)) . 25 | (P (SP empty2 start2) (DP p1)) = 26 | P (SP (empty1 && empty2) 27 | (if not empty1 then start1 else start1 `union` start2)) 28 | (DP (p2.p1)) 29 | 30 | instance (Cat.Category (Parser s) , Eq s) => Arrow (Parser s) where 31 | arr f = P (SP True []) (DP (\(b,s) -> (f b,s))) 32 | first (P sp (DP p)) = P sp (DP (\((b,d),s) -> 33 | let (c, s') = p (b,s) 34 | in ((c,d),s'))) 35 | 36 | -------------------------------------------------------------------------------- /C14/PipesTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | import Pipes 3 | import qualified Pipes.Prelude as P 4 | import Control.Monad 5 | 6 | hello :: Pipe String String IO r 7 | hello = forever $ do 8 | lift $ putStr "Please tell me your name:" 9 | name <- await 10 | yield ("Hello " ++ name) 11 | 12 | say_hello :: Effect IO () 13 | say_hello = P.stdinLn >-> hello >-> P.stdoutLn 14 | 15 | main1 = runEffect say_hello 16 | 17 | await' :: Monad m => Consumer a m a 18 | await' = await 19 | 20 | yield' :: Monad m => a -> Producer' a m () 21 | yield' = yield 22 | 23 | drop1keep1 :: Monad m => Pipe a a m () 24 | drop1keep1 = P.drop 1 >-> P.take 1 25 | 26 | alternatives :: Monad m => Pipe a a m () 27 | alternatives = replicateM_ 5 drop1keep1 28 | 29 | test1 :: [Int] 30 | test1 = P.toList ((each [1..]) >-> alternatives) 31 | 32 | test2 :: IO () 33 | test2 = runEffect (for (each [1.. ] >-> alternatives) (lift.print)) 34 | 35 | plus' :: Monad m => Consumer Int m String 36 | plus' = do 37 | a <- await 38 | b <- await 39 | return $ show $ a + b 40 | 41 | plus :: Monad m => Pipe Int String m () 42 | plus = forever $ do 43 | a <- await 44 | b <- await 45 | yield $ show $ a + b 46 | 47 | -- runEffect $ (lift readLn >~ plus) >~ P.stdoutLn 48 | -------------------------------------------------------------------------------- /C05/chapter05.hs: -------------------------------------------------------------------------------- 1 | import Prelude hiding (even,odd) 2 | 3 | factorial :: Integer -> Integer 4 | factorial n = if n < 0 then error "n is less than 0" 5 | else if n==0 then 1 6 | else n * factorial (n-1) 7 | 8 | mygcd :: Int -> Int -> Int 9 | mygcd x y = if y == 0 then x else mygcd y (mod x y) 10 | 11 | power :: Int -> Int -> Int 12 | power 0 0 = error "cannot calculate power 0 0" 13 | power _ 0 = 1 14 | power x n = x * power x (n-1) 15 | 16 | power' :: Int -> Int -> Int 17 | power' 0 0 = error "cannot calculate power 0 0" 18 | power' _ 0 = 1 19 | power' x n | odd n = let p = power' x ((n-1) `div` 2) in x * p * p 20 | | otherwise = let p = power' x (n `div` 2) in p * p 21 | 22 | product' [] = 1 23 | product' (x:xs) = x * product' xs 24 | 25 | last' :: [a] -> a 26 | last' [] = error "empty list" 27 | last' [x] = x 28 | last' (_:xs) = last' xs 29 | 30 | take' n _ | n <= 0 = [] 31 | take' _ [] = [] 32 | take' n (x:xs) = x : take' (n-1) xs 33 | 34 | elem' :: Eq a => a -> [a] -> Bool 35 | elem' _ [] = False 36 | elem' a (x:xs) = if a == x then True else elem' a xs 37 | 38 | total' [] n = n 39 | total' (x:xs) n = total' xs (n+x) 40 | 41 | total xs = total' xs 0 42 | 43 | even 0 = True 44 | even n = odd (n-1) 45 | 46 | odd 0 = False 47 | odd n = even (n-1) -------------------------------------------------------------------------------- /C20/QuickCheckGen.hs: -------------------------------------------------------------------------------- 1 | import Test.QuickCheck 2 | import Control.Monad 3 | 4 | newtype Exp = Exp String deriving (Show ,Eq) 5 | 6 | instance Arbitrary Exp where 7 | arbitrary = do 8 | n <- choose (0, 2) :: Gen Int 9 | case n of 10 | 0 -> do 11 | unaryOp <- 12 | elements ["", "+", "-", "sin ", "cos ", "log ", "ln ", "sqrt "] 13 | (Exp exp) <- arbitrary :: Gen Exp 14 | return (Exp (unaryOp ++ exp)) 15 | 1 -> do 16 | Exp exp <- arbitrary :: Gen Exp 17 | let bracketExp = "(" ++ exp ++ ")" 18 | n1 <- choose (0, 1) :: Gen Int 19 | case n1 of 20 | 0 -> do 21 | binaryOp <- elements ["+", "-", "*", "/", "^"] 22 | (Exp exp1) <- arbitrary :: Gen Exp 23 | return (Exp (bracketExp ++ binaryOp ++ exp1)) 24 | 1 -> do 25 | return (Exp bracketExp) 26 | 2 -> do 27 | num <- 28 | oneof [liftM show (choose (-20, 20) :: Gen Int), elements ["pi", "e"]] 29 | n1 <- choose (0, 1) :: Gen Int 30 | case n1 of 31 | 0 -> do 32 | binaryOp <- elements ["+", "-", "*", "/", "^"] 33 | (Exp exp1) <- arbitrary :: Gen Exp 34 | return (Exp (num ++ binaryOp ++ exp1)) 35 | 1 -> do 36 | return (Exp (num)) 37 | 38 | -------------------------------------------------------------------------------- /C14/FreeMonad2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs , KindSignatures #-} 2 | import Control.Monad 3 | 4 | data Interaction :: * -> * where 5 | Return :: a -> Interaction a 6 | Say :: String -> (() -> Interaction b) -> Interaction b 7 | Ask :: (String -> Interaction b) -> Interaction b 8 | 9 | instance Functor Interaction where 10 | fmap f (Return a) = Return (f a) 11 | fmap f (Say str fu) = Say str (\() -> fmap f (fu ())) 12 | fmap f (Ask fs) = Ask (\str -> fmap f (fs str)) 13 | 14 | instance Applicative Interaction where 15 | pure = return 16 | (<*>) = ap 17 | 18 | instance Monad Interaction where 19 | return = Return 20 | Return x >>= f = f x 21 | Say msg k >>= f = Say msg ((>>=f).k) 22 | Ask k >>= f = Ask ((>>=f).k) 23 | 24 | say :: String -> Interaction () 25 | say msg = Say msg Return 26 | ask :: Interaction String 27 | ask = Ask Return 28 | 29 | run :: Interaction a -> IO a 30 | run (Return x) = return x 31 | run (Say msg k) = putStrLn msg >>= run.k 32 | run (Ask k) = getLine >>= run.k 33 | 34 | run2 :: Interaction a -> [String] -> [String] 35 | run2 (Return _) is = [] 36 | run2 (Say msg k ) is = [msg] ++ run2 (k ()) is 37 | run2 (Ask k) (i:is) = run2 (k i) is 38 | 39 | test1 :: Interaction () 40 | test1 = do 41 | say "who are you" 42 | a <- ask 43 | say $ "hello " ++ a 44 | -------------------------------------------------------------------------------- /C21/PingPong.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | 5 | module Main where 6 | 7 | import System.Environment (getArgs) 8 | import GHC.Generics 9 | import Data.Binary 10 | import Data.Rank1Typeable 11 | 12 | import Control.Monad 13 | 14 | import Control.Distributed.Process 15 | import Control.Distributed.Process.Node (initRemoteTable, runProcess) 16 | import Control.Distributed.Process.Backend.SimpleLocalnet 17 | 18 | data Ping = Ping ProcessId 19 | deriving (Generic, Typeable, Binary) 20 | data Pong = Pong ProcessId 21 | deriving (Generic, Typeable, Binary) 22 | 23 | pingPong :: Process () 24 | pingPong = forever $ do 25 | self <- getSelfPid 26 | Ping pid <- expect 27 | say $ "Ping from " ++ show pid 28 | send pid (Pong self) 29 | 30 | pingPong' :: Process () 31 | pingPong' = forever $ do 32 | self <- getSelfPid 33 | receiveWait 34 | [ match $ \(Ping pid) -> send pid (Pong self) 35 | , match $ \(Pong pid) -> send pid (Ping self) ] 36 | 37 | main :: IO () 38 | main = do 39 | [port] <- getArgs 40 | backend <- initializeBackend "localhost" port initRemoteTable 41 | node <- newLocalNode backend 42 | peers <- findPeers backend 1000000 43 | runProcess node $ do 44 | self <- getSelfPid 45 | register "pingPongProc" self 46 | forM_ peers $ \nid -> nsendRemote nid "pingPongProc" () 47 | pingPong 48 | -------------------------------------------------------------------------------- /C12/VarBind.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.Reader 2 | import Data.List (lookup) 3 | 4 | data Exp = Val Int 5 | | Var String 6 | | Add Exp Exp 7 | | Decl Bind Exp deriving (Show ,Eq) 8 | 9 | type Bind = (String,Int) 10 | type Env = [Bind] 11 | 12 | updateEnv :: Bind -> Env -> Env 13 | updateEnv = (:) 14 | 15 | resolve :: Exp -> Reader Env (Maybe Exp) 16 | resolve (Val i ) = return (Just (Val i)) 17 | resolve (Var s ) = do 18 | env <- ask 19 | case lookup s env of 20 | Nothing -> return Nothing 21 | Just v -> return (Just (Val v)) 22 | 23 | resolve (Add e1 e2) = do 24 | re1 <- resolve e1 25 | case re1 of 26 | Nothing -> return Nothing 27 | Just a -> do 28 | re2 <- resolve e2 29 | case re2 of 30 | Nothing -> return Nothing 31 | Just b -> return (Just (Add a b)) 32 | 33 | resolve (Decl b e) = local (updateEnv b) (resolve e) 34 | 35 | -- let x=3 in let y=5 in x + (y+6) 36 | test1 :: Exp 37 | test1 = Decl ("x",3) (Decl ("y",5) (Add (Var "x") (Add (Var "y") (Val 6)))) 38 | 39 | --let x = 2 in x + let x = 3 in x 40 | test2 :: Exp 41 | test2 = Add (Decl ("x",2) (Var "x")) (Decl ("x",3) (Var "x")) 42 | -------------------------------------------------------------------------------- /C16/TypeComputation2.hs: -------------------------------------------------------------------------------- 1 | -- TypeComputation2.hs 2 | {-# LANGUAGE KindSignatures,GADTs,TypeOperators,DataKinds, 3 | UndecidableInstances,StandaloneDeriving, 4 | ExistentialQuantification, TypeFamilies #-} 5 | 6 | data Nat = Z | S Nat deriving (Eq, Show) 7 | 8 | type family (a :: Nat) + (b :: Nat) :: Nat where 9 | Z + m = m 10 | S n + m = n + S m 11 | 12 | type family (n :: Nat) * (m :: Nat) :: Nat where 13 | Z * m = Z 14 | S n * m = (n * m) + m 15 | 16 | 17 | 18 | data Vec a (n :: Nat) where 19 | Nil :: Vec a Z 20 | Cons :: a -> Vec a n -> Vec a (S n) 21 | 22 | deriving instance Show a => Show (Vec a n) 23 | 24 | vhead :: Vec a (S n) -> a 25 | vhead (Cons a v) = a 26 | 27 | vtail :: Vec a (S n) -> Vec a n 28 | vtail (Cons x xs) = xs 29 | {- 30 | append :: Vec a n -> Vec a m -> Vec a (n + m) 31 | append (Cons x xs) ys = Cons x (append xs ys) 32 | append Nil ys = ys 33 | -} 34 | toList :: Vec a n -> [a] 35 | toList Nil = [] 36 | toList (Cons x xs) = x : toList xs 37 | 38 | data SNat (n :: Nat) where 39 | SZ :: SNat Z 40 | SS :: SNat n -> SNat (S n) 41 | 42 | fromList :: SNat n -> [a] -> Vec a n 43 | fromList SZ [] = Nil 44 | fromList (SS n) (x:xs) = Cons x (fromList n xs) 45 | fromList _ _ = error "size not matched" 46 | 47 | replicate' :: SNat n -> a -> Vec a n 48 | replicate' SZ _ = Nil 49 | replicate' (SS n) a = Cons a (replicate' n a) 50 | -------------------------------------------------------------------------------- /C22/Fib.prof: -------------------------------------------------------------------------------- 1 | Thu Mar 09 15:38 2017 Time and Allocation Profiling Report (Final) 2 | 3 | Fib +RTS -p -RTS 4 | 5 | total time = 1.93 secs (1926 ticks @ 1000 us, 1 processor) 6 | total alloc = 630,777,192 bytes (excludes profiling overheads) 7 | 8 | COST CENTRE MODULE %time %alloc 9 | 10 | fib Main 100.0 100.0 11 | 12 | 13 | individual inherited 14 | COST CENTRE MODULE no. entries %time %alloc %time %alloc 15 | 16 | MAIN MAIN 39 0 0.0 0.0 100.0 100.0 17 | CAF GHC.IO.Encoding.CodePage 63 0 0.0 0.0 0.0 0.0 18 | CAF GHC.IO.Encoding 60 0 0.0 0.0 0.0 0.0 19 | CAF GHC.IO.Handle.Text 58 0 0.0 0.0 0.0 0.0 20 | CAF GHC.IO.Handle.FD 51 0 0.0 0.0 0.0 0.0 21 | CAF Main 46 0 0.0 0.0 100.0 100.0 22 | main Main 78 1 0.0 0.0 100.0 100.0 23 | fib_20 Main 81 1 0.0 0.0 0.9 0.8 24 | fib Main 82 21891 0.9 0.8 0.9 0.8 25 | fib_30 Main 79 1 0.0 0.0 99.1 99.2 26 | fib Main 80 2692537 99.1 99.2 99.1 99.2 27 | -------------------------------------------------------------------------------- /C21/RemoteSpawn.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.Binary 4 | import Data.ByteString.Lazy 5 | import Data.Rank1Dynamic 6 | import Control.Monad 7 | 8 | import Control.Distributed.Static hiding (initRemoteTable) 9 | import Control.Distributed.Process 10 | import Control.Distributed.Process.Closure 11 | import Control.Distributed.Process.Node (initRemoteTable, runProcess) 12 | import Control.Distributed.Process.Backend.SimpleLocalnet 13 | 14 | sendStr :: SendPort String -> Process () 15 | sendStr sp = sendChan sp "Hello world" 16 | 17 | sendStrStatic :: Static (SendPort String -> Process ()) 18 | sendStrStatic = staticLabel "$sendStr" 19 | 20 | decodeSPStatic :: Static (ByteString -> SendPort String) 21 | decodeSPStatic = staticLabel "$decodeSP" 22 | 23 | sendStrClosure :: SendPort String -> Closure (Process ()) 24 | sendStrClosure sp = closure decoder (encode sp) 25 | where decoder :: Static (ByteString -> Process ()) 26 | decoder = sendStrStatic `staticCompose` decodeSPStatic 27 | 28 | rtable :: RemoteTable 29 | rtable = 30 | registerStatic "$sendStr" (toDynamic sendStr) 31 | . registerStatic "$decodeSP" (toDynamic (decode :: ByteString -> SendPort String)) 32 | $ initRemoteTable 33 | 34 | main :: IO () 35 | main = do 36 | backend <- initializeBackend "localhost" "8000" rtable 37 | node <- newLocalNode backend 38 | runProcess node $ do 39 | (sp, rp) <- newChan 40 | nid <- getSelfNode 41 | void $ spawn nid (sendStrClosure sp) 42 | receiveChan rp >>= liftIO . Prelude.putStrLn 43 | -------------------------------------------------------------------------------- /C19/macro1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP,DeriveGeneric,DeriveDataTypeable #-} 2 | import GHC.Generics 3 | import Data.Typeable 4 | import Data.Data 5 | import Data.Aeson 6 | import Text.PrettyPrint.GenericPretty 7 | 8 | #define DERIVING deriving (Show, Generic, Data, Typeable) 9 | data Company = C {departments :: [Department]} DERIVING 10 | data Department = D {departmentName :: String, 11 | manager :: Person, 12 | workers :: [Person] } DERIVING 13 | data Person = P {personName :: Name, 14 | gender :: Gender, 15 | age :: Age } DERIVING 16 | 17 | data Name = N {familyName :: String, 18 | givenName :: String } DERIVING 19 | 20 | data Gender = Male | Female DERIVING 21 | 22 | type Age = Int 23 | 24 | #define MAX(a,b) (if (a < b) \ 25 | then (b) \ 26 | else (a)) 27 | 28 | foo = MAX(10,20) 29 | 30 | instance FromJSON Gender 31 | instance ToJSON Gender 32 | instance Out Gender 33 | 34 | #define EMPTY_INSTANCES(T) instance FromJSON (T); instance ToJSON (T); instance Out (T) 35 | 36 | EMPTY_INSTANCES(Name) 37 | EMPTY_INSTANCES(Person) 38 | EMPTY_INSTANCES(Department) 39 | EMPTY_INSTANCES(Company) 40 | 41 | 42 | #if defined(PAR) 43 | import Control.Parallel 44 | import Control.Parallel.Strategies 45 | import Control.DeepSeq 46 | #endif 47 | 48 | #if defined(PAR) 49 | test = sum ( map expensiveFunc myList `using` strat ) 50 | where strat = parListChunk 100 rseq 51 | #else 52 | test = sum ( map expensiveFunc myList ) 53 | #endif 54 | -------------------------------------------------------------------------------- /C21/SpawnSupervised.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DeriveAnyClass #-} 6 | 7 | module Main where 8 | 9 | import GHC.Generics 10 | import Data.Binary 11 | import Data.Rank1Typeable 12 | import Control.Monad 13 | 14 | import Control.Distributed.Process 15 | import Control.Distributed.Process.Closure 16 | import Control.Distributed.Process.Node (initRemoteTable, runProcess) 17 | import Control.Distributed.Process.Backend.SimpleLocalnet 18 | 19 | data Task = Task ProcessId Double Double 20 | deriving (Generic, Typeable, Binary) 21 | 22 | doTask :: Double -> Double -> Process Double 23 | doTask n d = do 24 | when (d == 0) $ die "Denominator cannot be zero!" 25 | return (n / d) 26 | 27 | worker :: NodeId -> Process () 28 | worker nid = forever $ do 29 | Task pid n d <- expect 30 | res <- callLocal $ doTask n d 31 | send pid res 32 | 33 | remotable ['worker] 34 | 35 | main :: IO () 36 | main = do 37 | backend <- initializeBackend "localhost" "2000" $ __remoteTable initRemoteTable 38 | node <- newLocalNode backend 39 | runProcess node $ do 40 | nid <- getSelfNode 41 | pid <- getSelfPid 42 | (wpid, _) <- spawnSupervised nid ($(mkClosure 'worker) nid) 43 | send wpid $ Task pid 5 2 44 | receiveWait 45 | [ match $ \(res :: Double) -> 46 | liftIO $ putStrLn $ "Succeed: " ++ show res 47 | , match $ \(pmn :: ProcessMonitorNotification) -> 48 | liftIO $ putStrLn $ "Worker died: " ++ show pmn ] 49 | -------------------------------------------------------------------------------- /C08/TwentyFour.hs: -------------------------------------------------------------------------------- 1 | import Data.List (permutations) 2 | 3 | data Exp = Val Double 4 | | Plus Exp Exp 5 | | Sub Exp Exp 6 | | Mult Exp Exp 7 | | Div Exp Exp deriving (Show,Eq) 8 | 9 | eval :: Exp -> Double 10 | eval (Val a ) = a 11 | eval (Plus a b ) = eval a + eval b 12 | eval (Sub a b ) = eval a - eval b 13 | eval (Mult a b ) = eval a * eval b 14 | eval (Div a b ) = eval a / eval b 15 | 16 | showExp :: Exp -> String 17 | showExp (Val a) = show a 18 | showExp (Plus a b) = "("++showExp a ++ "+" ++ showExp b++")" 19 | showExp (Sub a b) = "("++showExp a ++ "-" ++ showExp b++")" 20 | showExp (Mult a b) = "("++showExp a ++ "*" ++ showExp b++")" 21 | showExp (Div a b) = "("++showExp a ++ "/" ++ showExp b++")" 22 | 23 | divide :: [a] -> [([a],[a])] 24 | divide xs = [(take n xs ,drop n xs)| n <- [1..(length xs -1)]] 25 | 26 | buildExpressions :: ([Exp],[Exp]) -> [Exp] 27 | buildExpressions (es1,es2) = [op e1 e2 |e1<-es1, e2<- es2, 28 | op <- [Plus, Sub, Mult, Div]] 29 | 30 | toExpressions :: [Double] -> [Exp] 31 | toExpressions [] = [] 32 | toExpressions [x] = [Val x] 33 | toExpressions xs = concat [buildExpressions (toExpressions l, 34 | toExpressions r)| (l,r) <- divide xs ] 35 | 36 | generate :: [Double] -> [Exp] 37 | generate ns = concatMap toExpressions (permutations ns) 38 | 39 | twentyfour :: [Double] -> [String] 40 | twentyfour ns = [showExp x | x <- generate ns, eval x == 24.0 ] -------------------------------------------------------------------------------- /C06/Caesar.hs: -------------------------------------------------------------------------------- 1 | import Data.Char (ord, chr, isLower) 2 | 3 | char2int :: Char -> Int 4 | char2int c = ord c - ord 'a' 5 | 6 | int2char :: Int -> Char 7 | int2char n = chr (ord 'a' + n) 8 | 9 | shift :: Int -> Char -> Char 10 | shift n c | isLower c = int2char ((char2int c + n ) `mod` 26) 11 | | otherwise = c 12 | 13 | encode :: Int -> String -> String 14 | encode n xs = [shift n x | x <- xs] 15 | 16 | chisqr :: [Float] -> [Float] -> Float 17 | chisqr os es = sum [((o - e) ^ 2) / e | (o,e) <- zip os es] 18 | 19 | table :: [Float] 20 | table = [8.2, 1.5, 2.8, 4.3, 12.7, 2.2, 2.0, 6.1, 7.0, 0.2, 0.8, 4.0, 2.4, 6.7, 7.5, 1.9, 0.1, 6.0, 6.3, 9.1, 2.8, 1.0, 2.4, 0.2, 2.0, 0.1] 21 | 22 | count :: Char -> String -> Int 23 | count x xs = length [x' | x' <- xs, x == x'] 24 | 25 | percent :: Int -> Int -> Float 26 | percent n m = (fromIntegral n / fromIntegral m) * 100 27 | 28 | lowers :: String -> Int 29 | lowers xs = length [x | x <- xs, isLower x] 30 | 31 | freqs :: String -> [Float] 32 | freqs xs = [percent (count x xs) n | x <- ['a'..'z']] 33 | where n = lowers xs 34 | 35 | rotate :: Int -> [a] -> [a] 36 | rotate n xs = drop n xs ++ take n xs 37 | 38 | crack :: String -> String 39 | crack xs = encode (-factor) xs 40 | where 41 | factor = head (positions (minimum chitab) chitab) 42 | chitab = [chisqr (rotate n table') table | n <- [0..25]] 43 | table' = freqs xs 44 | 45 | positions :: Eq a => a -> [a] -> [Int] 46 | positions x xs = [i | (x',i) <- zip xs [0..], x == x'] -------------------------------------------------------------------------------- /C12/StackCalc/Scanner.hs: -------------------------------------------------------------------------------- 1 | module Scanner where 2 | import Data.Char 3 | import Calculator 4 | 5 | scanExp :: String -> [LitOp] 6 | scanExp [] = error "Excepted an expression" 7 | scanExp (' ':ts) = scanExp ts 8 | --scan prefix unary operator 9 | scanExp ('l':'o':'g':ts) = Right Log : scanExp ts 10 | scanExp ('s':'i':'n':ts) = Right Sin : scanExp ts 11 | scanExp ('c':'o':'s':ts) = Right Cos : scanExp ts 12 | scanExp ('s':'q':'r':'t':ts) = Right Sqrt : scanExp ts 13 | scanExp ('+':ts) = Right Posi : scanExp ts 14 | scanExp ('-':ts) = Right Nega : scanExp ts 15 | scanExp ('(':ts) = Right L_Par : scanExp ts 16 | scanExp xs = scanNum xs 17 | 18 | scanNum :: String -> [LitOp] 19 | scanNum ('e':ts) = Left (Const "e") : scanBin ts 20 | scanNum ('p':'i':ts) = Left (Const "pi") : scanBin ts 21 | scanNum xs | null num = error "Excepted a number or constant" 22 | | otherwise = case rest of 23 | ('.': r) -> let (float,r') = span isDigit r 24 | in Left (Val (read (num ++ "." ++ float) :: Float)) : scanBin r' 25 | r -> Left (Val (read num :: Float)) : scanBin r 26 | where (num, rest) = span isDigit xs 27 | 28 | scanBin :: String -> [LitOp] 29 | scanBin [] = [] 30 | scanBin (' ':ts) = scanBin ts 31 | scanBin ('+':ts) = Right Plus: scanExp ts 32 | scanBin ('-':ts) = Right Minu: scanExp ts 33 | scanBin ('*':ts) = Right Mult: scanExp ts 34 | scanBin ('/':ts) = Right Divi: scanExp ts 35 | scanBin ('^':ts) = Right Power:scanExp ts 36 | scanBin (')':ts) = Right R_Par:scanBin ts 37 | scanBin _ = error "Excepted an infix binary operator" 38 | -------------------------------------------------------------------------------- /C12/Writer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE FunctionalDependencies,TypeSynonymInstances,FlexibleInstances #-} 4 | 5 | import Control.Monad 6 | 7 | left,right :: Int -> (Int , String) 8 | left x = (x-1, "move left\n") 9 | right x = (x+1, "move right\n") 10 | 11 | move i = let (x,str1) = left i in 12 | let (y,str2) = left x in 13 | (y,str1++str2) 14 | 15 | newtype Writer w a = Writer { runWriter :: (a, w) } 16 | deriving Functor 17 | 18 | instance (Monoid w) => Monad (Writer w) where 19 | return x = Writer (x, mempty) 20 | (Writer (x,v)) >>= f =let (Writer (y, v')) = f x 21 | in Writer (y, v `mappend` v') 22 | 23 | instance Monoid w => Applicative (Writer w) where 24 | pure = return 25 | (<*>) = ap 26 | 27 | left', right' :: Int -> Writer String Int 28 | left' x = Writer (x-1, "move left\n") 29 | right' x = Writer (x+1, "move right\n") 30 | 31 | class (Monoid w, Monad m) => MonadWriter w m | m -> w where 32 | writer :: (a,w) -> m a 33 | writer ~(a, w) = do 34 | tell w 35 | return a 36 | 37 | tell :: w -> m () 38 | tell w = writer ((),w) 39 | listen :: m a -> m (a, w) 40 | pass :: m (a, w -> w) -> m a 41 | 42 | instance MonadWriter String (Writer String) where 43 | writer (a,w) = Writer (a,w) 44 | listen m = return (runWriter m) 45 | pass m = let ((a,f),s) = runWriter m in writer (a,f s) 46 | 47 | move' i = do 48 | x <- left' i 49 | tell "moved left once!\n gonna move again\n" 50 | y <- left' x 51 | return y -------------------------------------------------------------------------------- /C02/chapter02.hs: -------------------------------------------------------------------------------- 1 | type RGB = (Int,Int,Int) 2 | type Picture = [[RGB]] 3 | 4 | type ID = Int 5 | type BookName = String 6 | type Author = String 7 | type ISBN = Int 8 | type Publisher = String 9 | 10 | type Book = (ID, BookName, Author, ISBN, Publisher) 11 | 12 | i :: Int 13 | i = 5 14 | 15 | add, sub :: Int -> Int -> Int 16 | add a b = a + b 17 | sub a b = a - b 18 | {- 19 | f :: Num a => a -> a 20 | f x = 4 * x + 1 21 | -} 22 | area r = pi * r ^ 2 23 | 24 | f :: Num a => (a,a) -> a 25 | f (x,y) = 4*x + 5*y + 1 26 | 27 | f' :: Num a => a -> a -> a 28 | f' x y = 4*x + 5*y + 1 29 | 30 | f'' :: Num a => a -> a 31 | f'' y = 4*5 + 5*y + 1 32 | 33 | 34 | s :: Double -> Double -> Double -> Double 35 | s a b c = let p = (a + b + c) / 2 36 | in sqrt (p * (p - a) * (p - b) * (p - c)) 37 | 38 | s' :: Double -> Double -> Double -> Double 39 | s' a b c = sqrt (p * (p - a) * (p - b) * (p - c)) 40 | where 41 | p = (a + b + c) / 2 42 | 43 | isTwo :: Int -> Bool 44 | isTwo n = if n == 2 then True else False 45 | 46 | abs' :: (Num a,Ord a) => a -> a 47 | abs' n | n > 0 = n 48 | | otherwise = -n 49 | 50 | month :: Int -> Int 51 | month 1 = 31 52 | month 2 = 28 53 | month 3 = 31 54 | month 4 = 30 55 | month 5 = 31 56 | month 6 = 30 57 | month 7 = 31 58 | month 2 = 40 59 | month 8 = 31 60 | month 9 = 30 61 | month 5 = 20 62 | month 10 = 31 63 | month 11 = 30 64 | month 12 = 31 65 | month _ = error "invalid month" 66 | 67 | head' [] = error "empty list" 68 | head' (x:_) = x 69 | 70 | infixr 5 <->,<+> 71 | 72 | (<->),(<+>) :: Int -> Int -> Int 73 | (<->) x y = x - y 74 | (<+>) x y = x + y -------------------------------------------------------------------------------- /C12/State.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | 3 | newtype State s a = State { runState :: s -> (a,s) } 4 | deriving Functor 5 | 6 | newtype Reader r a = Reader { runReader :: r -> a } 7 | deriving Functor 8 | 9 | instance Monad (State s) where 10 | return x = State $ \s -> (x,s) 11 | (>>=) :: State s a -> (a -> State s b) -> State s b 12 | -- h :: a -> (a, s) 13 | -- f :: (a -> State s b) 14 | -- g :: (s -> (b, s)) 15 | (State h) >>= f = State $ \s -> let (a, newState) = h s 16 | (State g) = f a 17 | in g newState 18 | 19 | instance Applicative (State s) where 20 | pure = return 21 | (<*>) = ap 22 | 23 | evalState :: State s a -> s -> a 24 | evalState m s = fst (runState m s) 25 | 26 | evaluate :: State s a -> Reader s a 27 | evaluate s = Reader $ \e -> evalState s e 28 | 29 | readOnly :: Reader s a -> State s a 30 | readOnly r = State $ \s -> (runReader r s, s) 31 | 32 | data Tree a = Leaf a | Node (Tree a) a (Tree a) deriving (Show,Eq) 33 | 34 | labelTree :: Tree a -> Tree (a,Int) 35 | labelTree t = fst $ ntAux t 0 36 | 37 | ntAux :: Tree a -> Int -> (Tree (a,Int),Int) 38 | ntAux (Leaf a) n = (Leaf (a,n),n+1) 39 | ntAux (Node l a r) n = let (nn,n') = ((a,n),n+1) in 40 | let (ln,n'') = ntAux l n' in 41 | let (rn,n''') = ntAux r n'' in 42 | (Node ln nn rn, n''') 43 | 44 | test :: Tree Int 45 | test = Node (Node (Leaf 5) 3 (Leaf 2)) 7 (Leaf 9) 46 | -------------------------------------------------------------------------------- /C14/FreeMonad3.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs , KindSignatures,DeriveFunctor, StandaloneDeriving , FlexibleContexts,UndecidableInstances#-} 2 | {-# LANGUAGE RankNTypes #-} 3 | 4 | import Control.Monad 5 | 6 | data Free f a = Pure a | Free (f (Free f a)) deriving (Functor) 7 | 8 | deriving instance (Show (f (Free f a)), Show a) => Show (Free f a) 9 | deriving instance (Eq (f (Free f a)), Eq a) => Eq (Free f a) 10 | 11 | instance Functor f => Monad (Free f) where 12 | return = Pure 13 | -- (>>=) :: Free f a -> (a -> Free f b) -> Free f b 14 | Pure x >>= f = f x 15 | Free c >>= f = Free (fmap (>>= f) c) 16 | 17 | instance Functor f => Applicative (Free f) where 18 | pure = Pure 19 | (<*>) = ap 20 | 21 | data InteractionOp :: * -> * where 22 | Say :: String -> (() -> r) -> InteractionOp r 23 | Ask :: (String -> r) -> InteractionOp r 24 | 25 | deriving instance Functor InteractionOp 26 | type Interaction = Free InteractionOp 27 | 28 | say :: String -> Interaction () 29 | say msg = Free (Say msg Pure) 30 | ask :: Interaction String 31 | ask = Free (Ask Pure) 32 | 33 | test1 = do 34 | say "who are you" 35 | a <- ask 36 | say $ "hello " ++ a 37 | 38 | run1 :: InteractionOp a -> IO a 39 | run1 (Say msg k) = putStrLn msg >>= \_ -> return (k ()) 40 | run1 (Ask fstr) = do 41 | l <- getLine 42 | return (fstr l) 43 | 44 | run2 :: [a] -> InteractionOp a -> [a] 45 | run2 = undefined 46 | 47 | free :: (Functor f, Monad g) => (forall a. f a -> g a) -> (forall a. Free f a -> g a) 48 | free f (Pure a) = return a 49 | free f (Free fa) = join (f (fmap (free f) fa)) 50 | 51 | retract :: Monad f => Free f a -> f a 52 | retract (Pure a) = return a 53 | retract (Free as) = as >>= retract 54 | -------------------------------------------------------------------------------- /C08/Sugar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiWayIf #-} 2 | {-# LANGUAGE PatternGuards #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | {-# LANGUAGE PatternSynonyms #-} 5 | 6 | import Data.Sequence 7 | 8 | foo a1 a2 = if | a1 > 10 -> if | a1 < 10 && a2 > 50 -> True 9 | | a1 >= 10 && a2 < 30 -> False 10 | | a1 < 10 -> True 11 | | otherwise -> False 12 | 13 | data Shape = Triangle Int Int Int | Circle Int 14 | 15 | isValidShape :: Shape -> Bool 16 | isValidShape s | Circle r <- s, r > 0 = True 17 | isValidShape s | Triangle a b c <- s, 18 | a > 0 && b > 0 && c > 0, 19 | a + b > c && a + c > b && b + c > a 20 | = True 21 | isValidShape _ = False 22 | 23 | one2ten :: Seq Int 24 | one2ten = fromList [1..4] 25 | 26 | match :: Seq Int -> Seq Int -> (Int, Seq Int) 27 | match s1 s2 = case viewl s1 of 28 | EmptyL -> case viewr s2 of 29 | EmptyR -> (0, s2) 30 | xs :> x -> (x, xs) 31 | a :< as -> case viewr s2 of 32 | EmptyR -> (a, as) 33 | xs :> x -> (a + x, xs >< as) 34 | 35 | match' :: Seq Int -> Seq Int -> (Int, Seq Int) 36 | match' (viewl -> EmptyL) s2@(viewr -> EmptyR) = (0,s2) 37 | match' (viewl -> EmptyL) (viewr -> xs :> x) = (x,xs) 38 | match' (viewl -> a :< as) (viewr -> EmptyR) = (a,as) 39 | match' (viewl -> a :< as) (viewr -> xs :> x) = (a + x, xs >< as) 40 | 41 | data Exp = Val Int | Exp String [Exp] 42 | 43 | pattern Add t1 t2 = Exp "+" [t1,t2] 44 | pattern Sub t1 t2 = Exp "-" [t1,t2] 45 | 46 | eval (Val n) = n 47 | eval (Add t1 t2) = eval t1 + eval t2 48 | eval (Sub t1 t2) = eval t1 + eval t2 -------------------------------------------------------------------------------- /C24/YampaIntro.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | 3 | import FRP.Yampa 4 | 5 | -- test0 = reactimate (return 100.0) 6 | -- (\_ -> return (1.0, Just 5)) 7 | -- (\_ b -> (putStrLn $ show b) >> return False) 8 | -- (arr (+1)) 9 | 10 | -- test1 = reactimate (return (100.0)) 11 | -- (\_ -> return (1.0, Just 5)) 12 | -- (\c b -> (putStrLn $ show b) >> if b == 6.0 then return True else return False) 13 | -- (arr (+1)) 14 | 15 | type Pos = Double 16 | type Vel = Double 17 | 18 | type Ball = (Pos, Vel) 19 | 20 | g :: Double 21 | g = 9.81 22 | 23 | fallingBall :: Ball -> SF () (Pos,Vel) 24 | fallingBall (y0 ,v0) = proc () -> do 25 | v <- (v0 +) ^<< integral -< (-g) 26 | y <- (y0 +) ^<< integral -< v 27 | returnA -< (y,v) 28 | 29 | detectBounce :: SF (Double, t) (Event (Double, t)) 30 | detectBounce = when (\(pos , v) -> pos <= 0) 31 | 32 | elasticBall :: Ball -> SF () Ball 33 | elasticBall (p, v) = rswitchWhen (fallingBall (p, v)) 34 | detectBounce (fallingBall . \(p',v') -> (p',negate v')) 35 | 36 | when :: (a -> Bool) -> SF a (Event a) 37 | when p = proc a -> do 38 | event <- edge -< p a 39 | returnA -< (event `tag` a) 40 | 41 | 42 | rswitchWhen :: SF a b -> SF b (Event c) -> (c -> SF a b) -> SF a b 43 | rswitchWhen sf sfe f = rswitch (sf >>> forkSecond sfe) 44 | (\e -> f e >>> forkSecond sfe) 45 | 46 | rswitch :: SF a (b, Event c) -> (c -> SF a (b, Event c)) -> SF a b 47 | rswitch sf f = switch sf (\e -> rswitch (f e >>> sfSecond notYet) f) 48 | 49 | forkSecond :: SF a c' -> SF a (a, c') 50 | forkSecond sf = sfFork >>> sfSecond sf 51 | 52 | sfSecond sf = identity *** sf 53 | 54 | sfFork = arr fork 55 | 56 | fork a = (a,a) 57 | -------------------------------------------------------------------------------- /C14/ContMonad3.hs: -------------------------------------------------------------------------------- 1 | -- ContMonad3.hs 2 | import Control.Monad.Cont 3 | 4 | fibs2 :: Int -> Cont r Int 5 | fibs2 0 = return 1 6 | fibs2 1 = return 1 7 | fibs2 n = do 8 | n1 <- callCC $ \k -> (fibs2 (n - 1)) 9 | n2 <- callCC $ \k -> (fibs2 (n - 2)) 10 | return (n1 + n2) 11 | 12 | print4 :: ContT r IO () 13 | print4 = do 14 | (goto, n) <- callCC $ \k -> let f x = k (f, x) in return (f,0) 15 | if n < 4 16 | then do 17 | lift $ putStrLn "Hello" 18 | goto (n + 1) 19 | else return () 20 | 21 | 22 | fact_cps2 :: Int -> Cont r Int 23 | fact_cps2 n = do 24 | (goto, acc, num) <- callCC $ \k -> let f x y = k (f,x,y) 25 | in return (f, 1, n) 26 | if num == 1 27 | then return acc 28 | else goto (acc * num) (num - 1) 29 | 30 | 31 | fact_cps2' n = (callCC $ \k -> let f x y = k (f,x,y) in return (f,1,n)) >>= 32 | \(goto,acc,num) -> if num == 1 33 | then return acc 34 | else goto (acc* num) (num - 1) 35 | 36 | 37 | fact_cps2'' n = cont (\h -> runCont (let f = \x y -> (cont $ \_ -> h (f,x,y)) in return (f,1,n)) h) >>= 38 | \(goto,acc,num) -> if num == 1 39 | then return acc 40 | else goto (acc* num) (num - 1) 41 | 42 | fact_cps2''' n = \br -> 43 | (\h -> (let f = \x y -> (\_ -> h (f,x,y)) 44 | in \k -> k (f,1,n)) h) 45 | (\a -> ((\(goto,acc,num) -> if num == 1 46 | then \k -> k acc 47 | else goto (acc* num) (num - 1)) a) (\b -> br b)) 48 | -------------------------------------------------------------------------------- /C06/ShortestPath.hs: -------------------------------------------------------------------------------- 1 | -- ShortestPath.hs 2 | import Data.List (transpose,minimumBy) 3 | import Data.Ord (comparing) 4 | 5 | type Distance = Double 6 | type Name = String 7 | type Direction = String 8 | type Weight = (Distance, Direction) 9 | 10 | zipD :: [Name] -> [[String]] 11 | zipD ns = [[(start++"->"++des)| des <- ns ]|start <- ns] 12 | 13 | zipW :: [[Distance]] -> [Name] -> [[Weight]] 14 | zipW ds ns = [zip d n | (d, n) <- zip ds (zipD ns)] 15 | 16 | tuplePlus :: Weight -> Weight -> Weight 17 | tuplePlus (d1,n1) (d2,n2) = (d1+d2,n1++destination) 18 | where (from,destination) = break (=='-') n2 19 | 20 | type RouteMap = [[Weight]] 21 | 22 | step ::RouteMap -> RouteMap -> RouteMap 23 | step a b = [[minimumBy (comparing fst) $ zipWith tuplePlus ar bc | bc <- transpose b]|ar<-a] 24 | 25 | infixl 5 |*| 26 | 27 | (|*|) :: Num a => [[a]] -> [[a]] -> [[a]] 28 | (|*|) a b = [[ sum $ zipWith (*) ar bc | bc <- transpose b ] | ar <- a] 29 | 30 | iteration :: Int -> (a -> a) -> a -> a 31 | iteration 0 f x = x 32 | iteration n f x = iteration (n-1) f (f x) 33 | 34 | steps :: Int -> RouteMap -> RouteMap 35 | steps n route = iteration n (step route) route 36 | 37 | fix f x = if dss == dss' then x else fix f x' 38 | where 39 | x' = f x 40 | dss = [fst $ unzip ds|ds<-x'] 41 | dss' = [fst $ unzip ds|ds<-x ] 42 | 43 | path :: [[Distance]] -> [Name] -> RouteMap 44 | path dis ns = fix (step route) route 45 | where route = zipW dis ns 46 | 47 | infinity :: Fractional a => a 48 | infinity = 1/0 49 | 50 | i = infinity 51 | 52 | graph:: [[Distance]] 53 | graph = [[0,6,2,i,7], 54 | [6,0,3,i,i], 55 | [2,3,0,1,5], 56 | [i,i,1,0,4], 57 | [7,i,5,4,0]] 58 | 59 | names = ["A","B","C","D","E"] -------------------------------------------------------------------------------- /C09/Parser.hs: -------------------------------------------------------------------------------- 1 | -- Parser.hs 2 | {-# LANGUAGE DeriveFunctor #-} 3 | import Control.Applicative 4 | import Data.Char 5 | 6 | newtype Parser a = Parser { runParser :: String -> Maybe (a,String) } 7 | deriving Functor 8 | 9 | instance Applicative Parser where 10 | pure a = Parser $ \str -> Just (a,str) 11 | (<*>) fp a = Parser $ \str -> 12 | case runParser fp str of 13 | Nothing -> Nothing 14 | Just (ab,s) -> case runParser a s of 15 | Nothing -> Nothing 16 | Just (at,s1) -> Just (ab at,s1) 17 | 18 | instance Alternative Parser where 19 | empty = Parser $ \_ -> Nothing 20 | (<|>) a b = Parser $ \str -> case runParser a str of 21 | Nothing -> runParser b str 22 | just -> just 23 | 24 | satisfy :: (Char -> Bool) -> Parser Char 25 | satisfy f = Parser $ \str -> case str of 26 | [] -> Nothing 27 | s:ss -> if f s then Just (s,ss) else Nothing 28 | 29 | char :: Char -> Parser Char 30 | char c = satisfy (==c) 31 | 32 | number :: Parser Int 33 | number = fmap (foldl (\x y -> 10*x+y) 0) (many digit) 34 | where digit = fmap digitToInt (satisfy isDigit) 35 | 36 | sequ :: Parser a -> Parser [a] -> Parser [a] 37 | sequ x y = Parser $ \str -> case runParser x str of 38 | Nothing -> Nothing 39 | Just (s,ss) -> case runParser y ss of 40 | Nothing -> Nothing 41 | Just (s1,ss1) -> Just (s:s1,ss1) 42 | 43 | parseStr :: [Char] -> Parser [Char] 44 | parseStr strs = foldr sequ (Parser $ \str -> Just ("",str)) [char s| s <- strs] 45 | -------------------------------------------------------------------------------- /C25/ArrowAndMonad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances,Arrows #-} 2 | import Control.Monad 3 | import Control.Applicative 4 | import Control.Arrow hiding (Kleisli) 5 | import Control.Category 6 | import Prelude hiding ((.), id) 7 | 8 | newtype Kleisli m a b = Kleisli { runKleisli :: a -> m b } 9 | 10 | instance Monad m => Category (Kleisli m) where 11 | id = Kleisli return 12 | (Kleisli f) . (Kleisli g) = Kleisli (f <=< g) 13 | 14 | instance Monad m => Arrow (Kleisli m) where 15 | arr f = Kleisli (return . f) 16 | first (Kleisli f) = Kleisli (\ ~(b,d) -> f b >>= \c -> return (c,d)) 17 | second (Kleisli f) = Kleisli (\ ~(d,b) -> f b >>= \c -> return (d,c)) 18 | 19 | instance {-# OVERLAPPABLE #-} (Arrow arr) => Functor (arr a) where 20 | -- f :: b -> c 21 | -- ab :: arr a b 22 | -- res :: arr a c 23 | fmap f ab = proc c -> do 24 | b <- ab -< c 25 | returnA -< f b 26 | 27 | instance {-# OVERLAPPABLE #-} (Arrow arr) => Applicative (arr a) where 28 | pure x = arr (\a -> x) 29 | -- f :: arr a (b -> c) 30 | -- x :: arr a b 31 | -- res :: arr a c 32 | (<*>) f x = proc a -> do 33 | bc <- f -< a 34 | b <- x -< a 35 | returnA -< bc b 36 | 37 | instance {-# OVERLAPPABLE #-} ArrowApply a => Monad (a ()) where 38 | return x = arr $ \_ -> x 39 | -- x :: a () b 40 | -- f :: b -> a () c 41 | -- res :: a () c 42 | x >>= f = proc () -> do 43 | b <- x -< () 44 | ac <- arr f -< b 45 | c <- ac -<< () 46 | returnA -< c 47 | 48 | x >>= f = x >>> (arr $ \x -> let h = f x in (h, ())) >>> app 49 | 50 | instance (ArrowApply a, ArrowPlus a) => Alternative (a ()) where 51 | empty = zeroArrow 52 | x <|> y = (x <+> y) 53 | 54 | foo :: Kleisli IO String () 55 | foo = proc str -> do 56 | ln <- Kleisli (\() -> getLine) -< () 57 | () <- Kleisli putStrLn -< ln 58 | returnA -< () 59 | -------------------------------------------------------------------------------- /C25/ArrowAndApplicative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor,FlexibleInstances,Arrows,TupleSections #-} 2 | import Control.Arrow hiding (Kleisli(..)) 3 | import Control.Category hiding (Kleisli(..)) 4 | 5 | import Prelude hiding (id, (.)) 6 | 7 | newtype SF a b = SF {runSF :: [a] -> [b]} deriving Functor 8 | 9 | instance Applicative (SF b) where 10 | pure x = SF $ \a -> map (const x) a 11 | -- f :: [b] -> [a -> b1] 12 | -- x :: [b] -> [a] 13 | -- res :: [b] -> [b1] 14 | (<*>) (SF f) (SF x) = SF $ \bs -> zipWith ($) (f bs) (x bs) 15 | 16 | instance {-# OVERLAPPABLE #-} (Arrow arr) => Functor (arr a) where 17 | -- f :: b -> c 18 | -- ab :: arr a b 19 | -- res :: arr a c 20 | fmap f ab = proc c -> do 21 | b <- ab -< c 22 | returnA -< f b 23 | 24 | instance {-# OVERLAPPABLE #-} (Arrow arr) => Applicative (arr a) where 25 | pure x = arr (\a -> x) 26 | -- f :: arr a (b -> c) 27 | -- x :: arr a b 28 | -- res :: arr a c 29 | (<*>) f x = proc a -> do 30 | bc <- f -< a 31 | b <- x -< a 32 | returnA -< bc b 33 | 34 | newtype Kleisli m a b = Kleisli { runKleisli :: a -> m b } 35 | 36 | class Applicative f => Static f where 37 | delay :: Kleisli f a b -> Kleisli f () (a -> b) 38 | 39 | instance Static f => Category (Kleisli f) where 40 | id = Kleisli pure 41 | -- bfc :: Kleisli (b -> f c) 42 | -- afb :: Kleisli (a -> f b) 43 | -- res :: Kleisli (a -> f c) 44 | (.) bfc afb = Kleisli $ \a -> let fab = (runKleisli $ delay afb) () 45 | fbc = (runKleisli $ delay bfc) () 46 | in fbc <*> (fab <*> pure a) 47 | 48 | instance Static f => Arrow (Kleisli f) where 49 | arr f = Kleisli $ \a -> pure (f a) 50 | -- bfc :: Kleisli f b c 51 | -- res :: Kleisli f (b,d) (c,d) 52 | first bfc = Kleisli $ \(b,d) -> let fbc = (runKleisli $ delay bfc) () 53 | in pure (,d) <*> (fbc <*> pure b) 54 | -------------------------------------------------------------------------------- /C18/ZipN.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module ZipN where 3 | import Language.Haskell.TH 4 | 5 | genPE :: String -> Int -> ([Pat], [Exp]) 6 | genPE s n = let ns = [s++ (show i) | i <- [1..n]] 7 | in (map (VarP. mkName) ns, map (VarE. mkName) ns) 8 | 9 | genBT :: String -> Int -> ([TyVarBndr], [Type]) 10 | genBT s n = let ns = [s++ (show i) | i <- [1..n]] 11 | in (map (PlainTV. mkName) ns, map (VarT. mkName) ns) 12 | 13 | applyCurryT :: [Type] -> Type 14 | applyCurryT [x] = x 15 | applyCurryT (x:xs) = AppT (AppT ArrowT x) (applyCurryT xs) 16 | 17 | applyConT :: [Type] -> Type 18 | applyConT [x] = x 19 | applyConT (x1:x2:xs) = applyConT ((AppT x1 x2):xs) 20 | 21 | appExp :: [Exp] -> Exp 22 | appExp [x] = x 23 | appExp (x:y:xs) = appExp (AppE x y : xs) 24 | 25 | zipN :: Int -> Q [Dec] 26 | zipN n = return [sigDec, funDec] 27 | where 28 | -- 生成n个类型变量a1, a2, a3 ... 29 | (b, t) = genBT "a" n 30 | -- 生成匹配的模式与表达式 31 | (py,ey) = genPE "y" n 32 | (px,ex) = genPE "x" n 33 | (pxs,exs) = genPE "xs" n 34 | -- 生成函数名 35 | funcname = (mkName ("zip" ++ show n)) 36 | -- 构造类型[a0] -> [a1] -> ... -> [(a1,a2,...)] 37 | typ = applyCurryT $ map (AppT ListT) t ++ 38 | [(AppT ListT (applyConT (TupleT n : t)))] 39 | -- 构造类型签名 40 | sigDec = SigD funcname (ForallT b [] typ) 41 | -- 构造函数声名 42 | funDec = FunD funcname [Clause py (NormalB body) []] 43 | body = CaseE (TupE ey) 44 | [Match (TupP (map (\(x,xs) -> ConP '(:) [x,xs]) 45 | (zip px pxs))) 46 | (NormalB (AppE (AppE (ConE '(:)) (TupE ex)) 47 | (appExp (VarE funcname : exs)))) 48 | [], 49 | Match WildP (NormalB (ConE '[])) []] 50 | 51 | zips = fmap concat (sequence ([zipN x | x <- [4..10]])) -------------------------------------------------------------------------------- /C18/ExprQuote.hs: -------------------------------------------------------------------------------- 1 | -- ExprQuote.hs 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | module ExprQuote where 4 | import Text.Parsec 5 | import Text.Parsec.String 6 | import Data.Char(digitToInt, isDigit, isAlpha) 7 | import Language.Haskell.TH 8 | import Language.Haskell.TH.Quote 9 | import Data.Generics 10 | 11 | data Expr = Val Int 12 | | Id String 13 | | Add Expr Expr 14 | deriving (Show, Eq, Data) 15 | 16 | parseAdd :: Parser (Expr -> Expr -> Expr) 17 | parseAdd = do 18 | char '+' 19 | return Add 20 | 21 | parseInt :: Parser Expr 22 | parseInt = fmap Val $ fmap (foldl (\x y -> 10*x + y) 0) (many1 digit) 23 | where digit = fmap digitToInt (satisfy isDigit) 24 | 25 | parseId :: Parser Expr 26 | parseId = fmap Id $ many1 (satisfy isAlpha) 27 | 28 | parseExpr' :: Parser Expr 29 | parseExpr' = foldl1 (<|>) [parseInt, parseId, char '(' *> parseExpr <* char ')'] 30 | 31 | parseExpr :: Parser Expr 32 | parseExpr = chainl1 parseExpr' parseAdd 33 | 34 | generalized_parseExpr :: Monad m => String -> m Expr 35 | generalized_parseExpr s = case runParser parseExpr () "" s of 36 | Left err -> error $ show err 37 | Right e -> return e 38 | 39 | quoteExprExp :: String -> ExpQ 40 | quoteExprExp s = do 41 | exp <- generalized_parseExpr s 42 | dataToExpQ (const Nothing) exp 43 | {- 44 | quoteExprPat :: String -> Q Pat 45 | quoteExprPat s = do 46 | exp <- generalized_parseExpr s 47 | dataToPatQ (const Nothing) exp 48 | -} 49 | expr :: QuasiQuoter 50 | expr = QuasiQuoter { quoteExp = quoteExprExp, 51 | quotePat = quoteExprPat, 52 | quoteDec = undefined, 53 | quoteType = undefined } 54 | 55 | antiExprPat :: Expr -> Maybe (Q Pat) 56 | antiExprPat (Id v) = Just $ varP (mkName v) 57 | antiExprPat _ = Nothing 58 | 59 | quoteExprPat :: String -> Q Pat 60 | quoteExprPat s = do 61 | exp <- generalized_parseExpr s 62 | dataToPatQ (const Nothing `extQ` antiExprPat) exp -------------------------------------------------------------------------------- /C13/Transformer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | import Control.Monad.State (State, state) 3 | import Control.Monad 4 | newtype Identity a = Identity { runIdentity :: a } 5 | deriving Functor 6 | newtype IdentityT m a = IdentityT { runIdentityT :: m a } 7 | deriving Functor 8 | 9 | instance (Monad m) => Monad (IdentityT m) where 10 | return a = IdentityT $ return a 11 | m >>= k = IdentityT $ do 12 | a <- runIdentityT m 13 | runIdentityT (k a) 14 | 15 | instance (Monad m) => Applicative (IdentityT m) where 16 | pure = return 17 | (<*>) = ap 18 | 19 | type IState s a = IdentityT (State s) a 20 | 21 | push ::Int -> IState [Int] () 22 | push x = IdentityT $ state $ \xs -> ((),x:xs) 23 | 24 | pop :: IState [Int] Int 25 | pop = IdentityT $ state $ \(x:xs) -> (x,xs) 26 | 27 | -- data Maybe a = Nothing | Just a 28 | data MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) } deriving Functor 29 | 30 | instance Monad m => Monad (MaybeT m) where 31 | return x = MaybeT $ return (Just x) 32 | MaybeT a >>= f = MaybeT $ do 33 | result <- a 34 | case result of 35 | Nothing -> return Nothing 36 | Just x -> runMaybeT (f x) 37 | 38 | instance (Monad m) => Applicative (MaybeT m) where 39 | pure = return 40 | (<*>) = ap 41 | 42 | safeHead :: [a] -> MaybeT Identity a 43 | safeHead [] = MaybeT $ Identity Nothing 44 | safeHead (x:xs) = MaybeT $ Identity $ Just x 45 | 46 | --newtype State s a = State { runState :: s -> (s,a) } 47 | newtype StateT s m a = StateT { runStateT :: s -> m (a,s) } deriving Functor 48 | 49 | instance (Monad m) => Monad (StateT s m) where 50 | return a = StateT $ \s -> return (a, s) 51 | m >>= k = StateT $ \s -> do 52 | (a, s') <- (runStateT m) s 53 | runStateT (k a) s' 54 | 55 | instance (Monad m) => Applicative (StateT s m) where 56 | pure = return 57 | (<*>) = ap 58 | -------------------------------------------------------------------------------- /C03/Booleans.hs: -------------------------------------------------------------------------------- 1 | -- Boolean.hs 2 | import Prelude hiding ((/=),(==),not,and,or,(&&),(||)) 3 | 4 | (==) :: Bool -> Bool -> Bool 5 | (==) True True = True 6 | (==) False False = True 7 | (==) _ _ = False 8 | 9 | not :: Bool -> Bool 10 | not True = False 11 | not _ = True 12 | 13 | xor,and,or :: Bool -> Bool -> Bool 14 | xor b1 b2 = not (b1 == b2) 15 | 16 | and True b1 = b1 17 | and False _ = False 18 | 19 | or False b1 = b1 20 | or True _ = True 21 | 22 | {- 23 | and b1 b2 = if b1 then b2 else False 24 | or b1 b2 = if b1 then True else b2 25 | -} 26 | 27 | condition :: Bool -> a -> a -> a 28 | condition True t f = t 29 | condition False t f = f 30 | 31 | 32 | infix 4 == 33 | infix 4 /= 34 | infixl 3 && 35 | infixl 2 || 36 | 37 | (||) = or 38 | (&&) = and 39 | (/=) = xor 40 | 41 | hA :: Bool -> Bool -> (Bool,Bool) 42 | hA a b = (a /= b, a && b) 43 | 44 | fA a b c = let (axb,aab) = hA a b in 45 | let (axbxc,axbac) = hA axb c in (axbxc,aab || axbac) 46 | 47 | nand, nor ::Bool -> Bool -> Bool 48 | nand True True = False 49 | nand _ _ = True 50 | nor False False = True 51 | nor _ _ = False 52 | 53 | not1, not2 :: Bool -> Bool 54 | not1 b = nand b b 55 | not2 b = nor b b 56 | 57 | and1,and2 ::　Bool -> Bool -> Bool 58 | --and1 b1 b2 = not1 $ nand b1 b2 59 | and1 b1 b2 = nand (nand b1 b2) (nand b1 b2) 60 | -- and2 b1 b2 = nor (not2 b1) (not2 b2) 61 | and2 b1 b2 = nor (nor b1 b1) (nor b2 b2) 62 | 63 | or1, or2 :: Bool -> Bool -> Bool 64 | -- or1 b1 b2 = nand (not1 b1) (not1 b2) 65 | or1 b1 b2 = nand (nand b1 b1) (nand b2 b2) 66 | -- or2 b1 b2 = not2 $ nor b1 b2 67 | or2 b1 b2 = nor (nor b1 b2) (nor b1 b2) 68 | 69 | xor1 :: Bool -> Bool -> Bool 70 | -- xor1 b1 b2 = or1 (and1 b1 (not1 b2)) (and1 (not1 b1) b2) 71 | -- xor1 = nand (not1 (and1 b1 (not1 b2)) (not1 (and1 (not1 b1) b2) 72 | -- xor1 b1 b2 = nand (nand b1 (nand b1 b2)) (nand b2 (nand b1 b2)) 73 | 74 | xor1 b1 b2 = nand (nand b1 nb1b2) (nand b2 nb1b2) 75 | where nb1b2 = (nand b1 b2) 76 | 77 | xnor False False = True 78 | xnor False True = False 79 | xnor True False = False 80 | xnor True True = True 81 | -------------------------------------------------------------------------------- /C22/myhaskell/myhaskell.cabal: -------------------------------------------------------------------------------- 1 | -- Initial myhaskell.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | -- The name of the package. 5 | name: myhaskell 6 | 7 | -- The package version. See the Haskell package versioning policy (PVP) 8 | -- for standards guiding when and how versions should be incremented. 9 | -- http://www.haskell.org/haskellwiki/Package_versioning_policy 10 | -- PVP summary: +-+------- breaking API changes 11 | -- | | +----- non-breaking API additions 12 | -- | | | +--- code changes with no API change 13 | version: 0.0.0.1 14 | 15 | -- A short (one-line) description of the package. 16 | -- synopsis: 17 | 18 | -- A longer description of the package. 19 | -- description: 20 | 21 | -- The license under which the package is released. 22 | license: MIT 23 | 24 | -- The file containing the license text. 25 | license-file: LICENSE 26 | 27 | -- The package author(s). 28 | author: Empty 29 | 30 | -- An email address to which users can send suggestions, bug reports, and 31 | -- patches. 32 | maintainer: Empty 33 | 34 | -- A copyright notice. 35 | -- copyright: 36 | 37 | -- category: 38 | 39 | build-type: Simple 40 | 41 | -- Extra files to be distributed with the package, such as examples or a 42 | -- README. 43 | -- extra-source-files: 44 | 45 | -- Constraint on the version of Cabal needed to build this package. 46 | cabal-version: >=1.10 47 | 48 | 49 | library 50 | -- Modules exported by the library. 51 | -- exposed-modules: 52 | 53 | -- Modules included in this library but not exported. 54 | -- other-modules: 55 | 56 | -- LANGUAGE extensions used by modules in this package. 57 | -- other-extensions: 58 | 59 | -- Other library packages from which modules are imported. 60 | build-depends: base >=4.8 && <4.9 61 | 62 | -- Directories containing source files. 63 | hs-source-dirs: src 64 | 65 | -- Base language which the package is written in. 66 | default-language: Haskell2010 67 | -------------------------------------------------------------------------------- /C05/Sort.hs: -------------------------------------------------------------------------------- 1 | -- insertation sort 2 | insert :: Ord a => a -> [a] -> [a] 3 | insert x [] = [x] 4 | insert x (y:ys) | x < y = x:y:ys 5 | | otherwise = y:insert x ys 6 | 7 | insertionSort :: Ord a => [a] -> [a] 8 | insertionSort [] = [] 9 | insertionSort (x:xs) = insert x (insertionSort xs) 10 | 11 | -- bubble sort 12 | swaps :: Ord a => [a] -> [a] 13 | swaps [] = [] 14 | swaps [x] = [x] 15 | swaps (x1:x2:xs) | x1 > x2 = x2: swaps (x1:xs) 16 | | otherwise = x1: swaps (x2:xs) 17 | 18 | fix :: Eq a => (a -> a) -> a -> a 19 | fix f x = if x == x' then x else fix f x' 20 | where x' = f x 21 | 22 | bubbleSort :: Ord a => [a] -> [a] 23 | bubbleSort xs = fix swaps xs 24 | 25 | bubbleSort'' :: Ord a => [a] -> [a] 26 | bubbleSort'' [] = [] 27 | bubbleSort'' xs = bubbleSort'' initialElements ++ [lastElement] 28 | where swappedxs = swaps xs 29 | initialElements = init swappedxs 30 | lastElement = last swappedxs 31 | 32 | -- Selection sort 33 | delete :: Eq a => a -> [a]-> [a] 34 | delete _ [] = [] 35 | delete x (l:ls) | x == l = ls 36 | | otherwise = l:delete x ls 37 | 38 | selectionSort [] = [] 39 | selectoinSort xs = mini : selectionSort xs' 40 | where mini = minimum xs 41 | xs' = delete mini xs 42 | 43 | -- Quick sort 44 | quickSort :: Ord a => [a] -> [a] 45 | quickSort [] = [] 46 | quickSort (x:xs) = quickSort mini ++ [x] ++ quickSort maxi 47 | where mini = filter (=x) xs 49 | 50 | -- Merge sort 51 | merge :: Ord a => [a] -> [a] -> [a] 52 | merge xs [] = xs 53 | merge [] ys = ys 54 | merge (x:xs) (y:ys) | x > y = y:merge (x:xs) ys 55 | | otherwise = x:merge xs (y:ys) 56 | 57 | msort :: Ord a => [a] -> [a] 58 | msort xs = merge (msort x1) (msort x2) 59 | where 60 | (x1,x2) = halve xs 61 | halve xs = (take l xs, drop l xs) 62 | l = (length xs) `div` 2 -------------------------------------------------------------------------------- /C18/Person.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE DeriveGeneric #-} 7 | 8 | module Person where 9 | 10 | import System.Exit (exitFailure, exitSuccess) 11 | import System.IO (stderr, hPutStrLn) 12 | import qualified Data.ByteString.Lazy.Char8 as BSL 13 | import System.Environment (getArgs) 14 | import Control.Monad (forM_, mzero, join) 15 | import Control.Applicative 16 | import Data.Aeson.AutoType.Alternative 17 | import Data.Aeson(decode, Value(..), FromJSON(..), ToJSON(..), 18 | (.:), (.:?), (.=), object) 19 | import Data.Text (Text) 20 | import GHC.Generics 21 | 22 | -- | Workaround for https://github.com/bos/aeson/issues/287. 23 | o .:?? val = fmap join (o .:? val) 24 | 25 | 26 | data TopLevel = TopLevel { 27 | topLevelAge :: Int, 28 | topLevelName :: Text 29 | } deriving (Show,Eq,Generic) 30 | 31 | 32 | instance FromJSON TopLevel where 33 | parseJSON (Object v) = TopLevel <$> v .: "age" <*> v .: "name" 34 | parseJSON _ = mzero 35 | 36 | 37 | instance ToJSON TopLevel where 38 | toJSON (TopLevel {..}) = object ["age" .= topLevelAge, "name" .= topLevelName] 39 | 40 | 41 | 42 | 43 | parse :: FilePath -> IO TopLevel 44 | parse filename = do input <- BSL.readFile filename 45 | case decode input of 46 | Nothing -> fatal $ case (decode input :: Maybe Value) of 47 | Nothing -> "Invalid JSON file: " ++ filename 48 | Just v -> "Mismatched JSON value from file: " ++ filename 49 | Just r -> return (r :: TopLevel) 50 | where 51 | fatal :: String -> IO a 52 | fatal msg = do hPutStrLn stderr msg 53 | exitFailure 54 | 55 | main :: IO () 56 | main = do 57 | filenames <- getArgs 58 | forM_ filenames (\f -> parse f >>= (\p -> p `seq` putStrLn $ "Successfully parsed " ++ f)) 59 | exitSuccess 60 | 61 | 62 | -------------------------------------------------------------------------------- /C18/ZipN2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module ZipN2 where 3 | 4 | import Language.Haskell.TH 5 | import Language.Haskell.TH.Lib 6 | import Control.Monad 7 | import Data.List 8 | import Control.Applicative 9 | 10 | genBT :: String -> Int -> Q ([TyVarBndr], [TypeQ]) 11 | genBT name n = do 12 | let ns = [name++ (show i) | i <- [1..n]] 13 | tvb <- sequence $ map (return.plainTV.mkName) ns 14 | typ <- sequence $ map (return.varT.mkName) ns 15 | return (tvb,typ) 16 | 17 | genPE :: String -> Int -> Q ([PatQ],[ExpQ]) 18 | genPE name n = do 19 | let ns = [name++ (show i) | i <- [1..n]] 20 | pat <- sequence $ map (return.varP.mkName) ns 21 | exp <- sequence $ map (return.varE.mkName) ns 22 | return (pat,exp) 23 | 24 | applyCurryTQ :: [TypeQ] -> TypeQ 25 | applyCurryTQ = foldr1 (\t1 -> appT (appT arrowT t1)) 26 | 27 | applyConTQ :: [TypeQ] -> TypeQ 28 | applyConTQ xs = foldl1 appT xs 29 | 30 | applyExpQ :: [ExpQ] -> ExpQ 31 | applyExpQ = appsE 32 | 33 | zipN :: Int -> DecsQ 34 | zipN n = do 35 | -- 函数名为zip与一个数字 36 | let name = mkName ("zip" ++ show n) 37 | -- 生成n个类型变量a1, a2, a3 ... 38 | (tvb, tvar) <- genBT "a" n -- tvar :: [Q Type] 39 | -- 构造n个列表类型[a1], [a2], [a3] ... 40 | let listvar = map (appT listT) tvar 41 | -- 构造[(a1,a2...)]类型 42 | let lstuple = appT listT (applyConTQ (tupleT n : tvar)) 43 | -- [a1] -> [a2] -> ... [an] -> [(a1,a2,...)] 44 | let typ = applyCurryTQ (listvar ++ [lstuple]) 45 | -- zipn :: forall a1 a2 ... . [a1] -> [a2] ... [(a1,a2...)] 46 | sig <- sigD name (forallT tvb (return []) typ) 47 | -- 构造匹配模式与对应的变量 48 | (py, pyv) <- genPE "y" n 49 | (px, pxv) <- genPE "x" n 50 | (pxs, pxsv) <- genPE "xs" n 51 | let pcons x xs = [p| $x : $xs |] 52 | -- case模式匹配的模式，这里为一个多元元组 53 | let matchp = tupP (zipWith pcons px pxs) 54 | -- case模式匹配的函数体 55 | let matchb = [e| $(tupE pxv) : $(applyExpQ (varE name : pxsv))|] 56 | let body = normalB [e| case $(tupE pyv) of 57 | $matchp -> $matchb 58 | _ -> [] |] 59 | fun <- funD name [(clause py body [])] 60 | return [sig, fun] 61 | 62 | zips = fmap concat (sequence ([zipN x | x <- [4..10]])) 63 | -------------------------------------------------------------------------------- /C08/LogicCalculator.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | data Formula ts where 4 | Body :: Term Bool -> Formula () 5 | Forall :: Show a => [a] -> (Term a -> Formula as) -> Formula (a,as) 6 | Exist :: Show a => [a] -> (Term a -> Formula as) -> Formula (a,as) 7 | 8 | data Term t where 9 | Con :: a -> Term a 10 | (:&:) :: Term Bool -> Term Bool -> Term Bool 11 | (:|:) :: Term Bool -> Term Bool -> Term Bool 12 | (:<:) :: Term Int -> Term Int -> Term Bool 13 | (:=:) :: Term Int -> Term Int -> Term Bool 14 | (:+:) :: Term Int -> Term Int -> Term Int 15 | (:-:) :: Term Int -> Term Int -> Term Int 16 | Name :: String -> Term t 17 | 18 | ex1 :: Formula () 19 | ex1 = Body (Con True) 20 | 21 | ex2 :: Formula (Int, ()) 22 | ex2 = Forall [1..10] $ \n -> 23 | Body $ n :<: (n :+: Con 1) 24 | 25 | ex3 :: Formula (Bool, (Int, ())) 26 | ex3 = Forall [False, True] $ \p -> 27 | Forall [0..2] $ \n -> 28 | Body $ p :|: (Con 0 :<: n) 29 | 30 | ex4 :: Formula (Int, (Bool, ())) 31 | ex4 = Forall [1,2] $ \n -> 32 | Exist [False,True] $ \p -> Body $ p :|: (n :<: Con 2) 33 | 34 | eval :: Term t -> t 35 | eval (Con v) = v 36 | eval (p :&: q) = (eval p) && (eval q) 37 | eval (p :|: q) = (eval p) || (eval q) 38 | eval (n :<: m) = (eval n) < (eval m) 39 | eval (n :=: m) = (eval n) == (eval m) 40 | eval (n :+: m) = (eval n) + (eval m) 41 | eval (n :-: m) = (eval n) - (eval m) 42 | eval (Name _) = error "Cannot eval a Name" 43 | 44 | satisfiable :: Formula ts -> Bool 45 | satisfiable (Body body) = eval body 46 | satisfiable (Forall xs as) = and [satisfiable (as (Con y))| y <- xs] 47 | satisfiable (Exist xs as) = or [satisfiable (as (Con y))| y <- xs] 48 | 49 | solutions :: Formula ts -> [ts] 50 | solutions (Body body) = [()] 51 | solutions (Forall [] as) = [] 52 | solutions f@(Forall (x:xs) as) 53 | | satisfiable f = [(x,fs) | fs <- solutions (as (Con x))] 54 | ++ solutions (Forall xs as) 55 | | otherwise = [] 56 | solutions (Exist [] as) = [] 57 | solutions (Exist (x:xs) as) = [(x,fs) | fs <- solutions (as (Con x)), 58 | satisfiable (as (Con x))] 59 | ++ solutions (Forall xs as) -------------------------------------------------------------------------------- /C10/SafeEval.hs: -------------------------------------------------------------------------------- 1 | data Exp = Lit Integer 2 | | Add Exp Exp 3 | | Sub Exp Exp 4 | | Mul Exp Exp 5 | | Div Exp Exp 6 | 7 | eval :: Exp -> Integer 8 | eval (Lit n) = n 9 | eval (Add e1 e2) = eval e1 + eval e2 10 | eval (Sub e1 e2) = eval e1 - eval e2 11 | eval (Mul e1 e2) = eval e1 * eval e2 12 | eval (Div e1 e2) = eval e1 `div` eval e2 13 | {- 14 | safeEval :: Exp -> Maybe Integer 15 | safeEval (Lit n) = Just n 16 | safeEval (Add e1 e2) = case safeEval e1 of 17 | Nothing -> Nothing 18 | Just n1 -> case safeEval e2 of 19 | Nothing -> Nothing 20 | Just n2 -> Just (n1 + n2) 21 | 22 | safeEval (Sub e1 e2) = case safeEval e1 of 23 | Nothing -> Nothing 24 | Just n1 -> case safeEval e2 of 25 | Nothing -> Nothing 26 | Just n2 -> Just (n1 - n2) 27 | 28 | safeEval (Mul e1 e2) = case safeEval e1 of 29 | Nothing -> Nothing 30 | Just n1 -> case safeEval e2 of 31 | Nothing -> Nothing 32 | Just n2 -> Just (n1 * n2) 33 | 34 | safeEval (Div e1 e2) = case safeEval e1 of 35 | Nothing -> Nothing 36 | Just n1 -> case safeEval e2 of 37 | Nothing -> Nothing 38 | Just n2 -> if n2 == 0 39 | then Nothing 40 | else Just (n1 `div` n2) 41 | -} 42 | 43 | evalSeq :: Maybe Integer -> (Integer -> Maybe Integer) -> Maybe Integer 44 | evalSeq mi f = case mi of 45 | Nothing -> Nothing 46 | Just a -> f a 47 | 48 | safeEval (Add e1 e2) = 49 | safeEval e1 `evalSeq` \n1 -> 50 | safeEval e2 `evalSeq` \n2 -> 51 | Just (n1+n2) 52 | 53 | safeEval (Sub e1 e2) = 54 | safeEval e1 `evalSeq` \n1 -> 55 | safeEval e2 `evalSeq` \n2 -> 56 | Just (n1-n2) 57 | 58 | safeEval (Mul e1 e2) = 59 | safeEval e1 `evalSeq` \n1 -> 60 | safeEval e2 `evalSeq` \n2 -> 61 | Just (n1*n2) 62 | 63 | safeEval (Div e1 e2) = 64 | safeEval e1 `evalSeq` \n1 -> 65 | safeEval e2 `evalSeq` \n2 -> 66 | if n2==0 67 | then Nothing 68 | else Just (n1*n2) 69 | 70 | -------------------------------------------------------------------------------- /C14/ContMonad1.hs: -------------------------------------------------------------------------------- 1 | -- ContMonad1.hs 2 | {-# LANGUAGE DeriveFunctor #-} 3 | 4 | newtype Cont r a = Cont {runCont :: (a -> r) -> r} 5 | deriving Functor 6 | 7 | instance Applicative (Cont r) where 8 | pure a = Cont $ \k -> k a 9 | -- cab :: Cont r (a -> b) = ((a -> b) -> r) -> r 10 | -- ca :: Cont r a = (a -> r) -> r 11 | -- cab <*> ca :: Cont r b = (b -> r) -> r 12 | cab <*> ca = Cont $ \br -> runCont cab (\ab -> runCont ca (\a -> br (ab a))) 13 | 14 | instance Monad (Cont r) where 15 | return = pure 16 | -- ca :: Cont r a = (a -> r) -> r 17 | -- acb :: a -> Cont r b = a -> ((b -> r) -> r)) 18 | -- ca >>= acb :: Cont r b = (b -> r) -> r 19 | ca >>= acb = Cont $ \br -> runCont ca (\a -> runCont (acb a) (\b -> br b)) 20 | 21 | 22 | fact_cps :: Int -> Cont r Int 23 | fact_cps 0 = return 1 24 | fact_cps n = do 25 | n1 <- fact_cps (n - 1) 26 | return (n * n1) 27 | 28 | plus_1 :: Int -> Cont r Int 29 | plus_1 n = return (n + 1) 30 | 31 | 32 | div_10 :: Int -> Cont r Int 33 | div_10 n = return (div n 10) 34 | 35 | foo :: Int -> Cont r Int 36 | foo n = do 37 | r1 <- fact_cps n 38 | r2 <- div_10 r1 39 | r3 <- plus_1 r2 40 | return r3 41 | 42 | class Monad m => MonadCont m where 43 | callCC :: ((a -> m b) -> m a) -> m a 44 | 45 | instance MonadCont (Cont r) where 46 | -- callCC :: ((a -> Cont r b) -> Cont r a) -> Cont r a 47 | callCC f = Cont $ \h -> runCont (f (\a -> Cont $ \_ -> h a)) h 48 | 49 | fact_cps1 :: Int -> Cont r Int 50 | fact_cps1 0 = return 1 51 | fact_cps1 n = do 52 | n1 <- fact_cps (n - 1) 53 | callCC $ \k -> let r = n * n1 54 | in if r > 10000 55 | then k 0 56 | else return r 57 | 58 | fact_cps2 :: Int -> Cont r Int 59 | fact_cps2 n = do 60 | (goto, acc, num) <- callCC $ \k -> let f x y = k (f,x,y) 61 | in return (f, 1, n) 62 | if num == 1 63 | then return acc 64 | else goto (acc * num) (num - 1) 65 | 66 | fibs2 :: Int -> Cont r Int 67 | fibs2 0 = return 1 68 | fibs2 1 = return 1 69 | fibs2 n = do 70 | n1 <- callCC $ \k -> (fibs2 (n - 1)) 71 | n2 <- callCC $ \k -> (fibs2 (n - 2)) 72 | return (n1 + n2) 73 | -------------------------------------------------------------------------------- /C17/GenericShow.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE KindSignatures, TypeSynonymInstances, FlexibleInstances, TypeOperators, UndecidableInstances, DefaultSignatures,FlexibleContexts,DeriveGeneric,DeriveAnyClass #-} 2 | 3 | import GHC.Generics 4 | import Data.Typeable 5 | 6 | class GShow (a :: * -> *) where 7 | shows1 :: Bool -> a x -> ShowS 8 | 9 | instance GShow V1 where 10 | shows1 _ _ = error "cannot shows1 Void type" 11 | 12 | instance GShow U1 where 13 | shows1 _ U1 = id 14 | 15 | instance (GShow a, GShow b) => GShow (a :+: b) where 16 | shows1 b (L1 a) = shows1 b a 17 | shows1 b (R1 a) = shows1 b a 18 | 19 | instance (GShow a, GShow b) => GShow (a :*: b) where 20 | shows1 b (x :*: y) = shows1 b x . shows1 b y 21 | 22 | instance (Show0 a) => GShow (K1 i a) where 23 | shows1 _ (K1 a) = \x -> show0 a ++ x 24 | 25 | instance (GShow a) => (GShow (D1 b a)) where 26 | shows1 b (M1 a) = shows1 b a 27 | 28 | instance (GShow a, Constructor g) => GShow (C1 g a) where 29 | shows1 _ c@(M1 a) = showString "(". 30 | showString (conName c) . 31 | showString " " . 32 | wrapRecord (shows1 (conIsRecord c) a) . 33 | showString ")" 34 | where 35 | wrapRecord :: ShowS -> ShowS 36 | wrapRecord s | conIsRecord c = showString "{ " . s . showString " }" 37 | | otherwise = s 38 | 39 | instance (GShow a, Selector g) => GShow (S1 g a) where 40 | shows1 b s@(M1 a) | null (selName s) = shows1 b a 41 | | otherwise = showString (selName s) 42 | . showString " = " . shows1 b a . showChar ' ' 43 | 44 | shows_default :: (Generic a, GShow (Rep a)) => a -> ShowS 45 | shows_default x = shows1 False (from x) 46 | 47 | class Show0 a where 48 | show0 :: a -> String 49 | default show0 :: (Generic a, GShow (Rep a)) => a -> String 50 | show0 x = shows_default x "" 51 | 52 | instance Show0 Char where 53 | show0 a = show a 54 | instance Show0 Int where 55 | show0 a = show a 56 | instance Show0 Bool where 57 | show0 a = show a 58 | instance Show a => Show0 [a] where 59 | show0 a = show a 60 | 61 | data Person = Person {name :: String, age :: Int} deriving (Eq, Generic,Show0) 62 | 63 | data Person' = P String Int deriving (Eq,Generic,Show0) 64 | 65 | data Nat = Zero | Succ Nat deriving (Eq, Generic,Show0) 66 | 67 | data Sum a b = L a | R b deriving (Eq, Generic,Show0) 68 | -------------------------------------------------------------------------------- /C17/Generic1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, 2 | TypeOperators, 3 | TypeFamilies, 4 | KindSignatures, 5 | DefaultSignatures, 6 | FlexibleContexts 7 | #-} 8 | 9 | class GFunctor (f :: * -> *) where 10 | gfmap :: (a -> b) -> (f a -> f b) 11 | default gfmap :: (Generic1 f, GFunctor (Rep1 f)) => (a -> b) -> (f a -> f b) 12 | gfmap = defaultfmap 13 | 14 | class Generic (a :: *) where 15 | type family Rep a :: * -> * 16 | from :: a -> Rep a x 17 | to :: Rep a x -> a 18 | 19 | class Generic1 (f :: * -> *) where 20 | type Rep1 f :: * -> * 21 | -- type family Rep1 (f :: * -> *) :: * -> * 22 | from1 :: f p -> Rep1 f p 23 | to1 :: Rep1 f p -> f p 24 | 25 | data U1 p = U1 deriving (Show, Eq) 26 | -- | product (a,b) :*: in GHC.Generic 27 | data (:*:) a b p = a p :*: b p deriving (Eq,Show) 28 | -- | sum (Left a | Right b) :+: in GHC.Generic 29 | data (:+:) a b p = L (a p)| R (b p) deriving (Show, Eq) 30 | 31 | instance GFunctor U1 where 32 | gfmap f U1 = U1 33 | 34 | instance (GFunctor a , GFunctor b) => GFunctor (a :*: b) where 35 | gfmap f (a :*: b) = gfmap f a :*: gfmap f b 36 | 37 | instance (GFunctor a, GFunctor b) => GFunctor (a :+: b) where 38 | gfmap f (L a) = L (gfmap f a) 39 | gfmap f (R b) = R (gfmap f b) 40 | 41 | newtype Par p = Par {unPar :: p} deriving Show 42 | 43 | instance GFunctor Par where 44 | gfmap f (Par p) = Par (f p) 45 | 46 | newtype Rec a p = Rec {unRec :: a p} deriving Show 47 | 48 | instance (GFunctor a) => GFunctor (Rec a) where 49 | gfmap f (Rec a)= Rec (gfmap f a) 50 | 51 | data List a = Nil | Cons a (List a) deriving Show 52 | 53 | instance Generic1 List where 54 | type Rep1 List = U1 :+: (Par :*: (Rec List)) 55 | from1 Nil = L U1 56 | from1 (Cons a xs) = R (Par a :*: Rec xs) 57 | to1 (L U1) = Nil 58 | to1 (R (Par a :*: Rec xs)) = Cons a xs 59 | 60 | instance Generic1 Tree where 61 | type Rep1 Tree = U1 :+: (Par :*: (Rec Tree) :*: (Rec Tree)) 62 | from1 Leaf = L U1 63 | from1 (Node n l r) = R (Par n :*: Rec l :*: Rec r) 64 | to1 (L U1) = Leaf 65 | to1 (R (Par n :*: Rec l :*: Rec r)) = (Node n l r) 66 | 67 | instance GFunctor List 68 | 69 | defaultfmap :: (Generic1 t, GFunctor (Rep1 t)) => (a -> b) -> (t a -> t b) 70 | defaultfmap f x = to1 (gfmap f (from1 x)) 71 | 72 | data Tree a = Leaf | Node a (Tree a) (Tree a) deriving Show 73 | instance GFunctor Tree 74 | -------------------------------------------------------------------------------- /C11/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main where 3 | 4 | import System.Environment (getArgs) 5 | import Text.Printf 6 | import Control.Exception 7 | import Data.Word (Word8) 8 | import Data.Bits (shiftL) 9 | import Data.List (foldl') 10 | import System.IO 11 | import Data.String (fromString) 12 | import qualified Data.Text as T 13 | import qualified Data.Text.Encoding as Encode (decodeUtf8) 14 | import qualified Data.ByteString as DB 15 | import qualified Data.ByteString.Char8 as DBC (putStrLn) 16 | 17 | data WordIdx = WordIndex { 18 | word :: T.Text, 19 | offset :: Int, 20 | expLen :: Int 21 | } deriving Show 22 | 23 | byteToInt :: [Word8] -> Int 24 | byteToInt bs = foldl' (\x y -> shiftL (fromIntegral x) 8 + fromIntegral y) 0 bs 25 | 26 | getIndexList :: DB.ByteString -> [WordIdx] 27 | getIndexList "" = [] 28 | getIndexList str = WordIndex w (byteToInt o) (byteToInt e) : getIndexList left 29 | where 30 | w = Encode.decodeUtf8 $ DB.takeWhile (/= 0) str 31 | o = DB.unpack $ DB.take 4 (DB.drop 1 off) 32 | e = DB.unpack $ DB.take 4 (DB.drop 5 off) 33 | off = DB.dropWhile (/= 0) str 34 | left = DB.drop 9 off 35 | 36 | searchWord :: T.Text -> [WordIdx] -> Maybe WordIdx 37 | searchWord str [] = Nothing 38 | searchWord str xs | wrd < str = searchWord str behind 39 | | wrd > str = searchWord str front 40 | | otherwise = Just b 41 | where (front,b:behind) = splitAt (length xs `div` 2) xs 42 | wrd = T.toLower (word b) 43 | 44 | main :: IO () 45 | main = do 46 | arg <- getArgs 47 | case arg of 48 | [] -> print "Usage: Dict " 49 | (a:_) -> do 50 | idctIdx <- DB.readFile "./Dict/longman.idx" 51 | let is = getIndexList idctIdx 52 | let result = searchWord (fromString a) is 53 | case result of 54 | Nothing -> printf "Word \"%s\" not found" a 55 | Just wrd -> do 56 | bracket (openFile "./Dict/longman.dict" ReadMode) hClose $ \inh -> do 57 | hSeek inh AbsoluteSeek (toInteger $ offset wrd) 58 | hSetEncoding inh utf8 59 | explanation <- DB.hGet inh (expLen wrd) 60 | DBC.putStrLn explanation 61 | -------------------------------------------------------------------------------- /C13/Compiler.hs: -------------------------------------------------------------------------------- 1 | import Data.List 2 | import Control.Monad.Writer 3 | import Control.Monad.State 4 | 5 | type Name = Char 6 | type Label = Int 7 | 8 | data Exp = Val Int | Var Name | App Op Exp Exp deriving Show 9 | 10 | data Op = Add | Sub | Mul | Div deriving (Show , Eq) 11 | 12 | comexp :: Exp -> Code 13 | comexp (Val int) = [PUSH int] 14 | comexp (Var name) = [PUSHV name] 15 | comexp (App op e1 e2) = comexp e1 ++ comexp e2 ++ [DO op] 16 | 17 | data Prog = Assign Name Exp 18 | | If Exp Prog Prog 19 | | While Exp Prog 20 | | Seqn [Prog] 21 | deriving Show 22 | 23 | factorial :: Int -> Prog 24 | factorial n = Seqn [Assign 'A' (Val 1), 25 | Assign 'B' (Val n), 26 | While (Var 'B') ( 27 | Seqn [Assign 'A' (App Mul (Var 'A') (Var 'B')), 28 | Assign 'B' (App Sub (Var 'B') (Val 1))])] 29 | 30 | type Code = [Inst] 31 | data Inst = PUSH Int 32 | | PUSHV Name 33 | | POP Name 34 | | DO Op 35 | | JUMP Label 36 | | JUMPZ Label 37 | | LABEL Label 38 | deriving (Show) 39 | 40 | type WT a = WriterT Code (State Int) a 41 | 42 | fresh :: WT Int 43 | fresh = WriterT $ state (\s -> ((s,mempty),s+1)) 44 | 45 | mlabel (Assign name expr) = do tell $ comexp expr 46 | tell [POP name] 47 | 48 | mlabel (If expr prog1 prog2) = do n <- fresh 49 | m <- fresh 50 | tell $ comexp expr 51 | tell [JUMPZ n] 52 | mlabel prog1 53 | tell [JUMP m] 54 | tell [LABEL n] 55 | mlabel prog2 56 | tell [LABEL m] 57 | mlabel (While expr prog) = do n <- fresh 58 | m <- fresh 59 | tell [LABEL n] 60 | tell $ comexp expr 61 | tell [JUMPZ m] 62 | mlabel prog 63 | tell [JUMP n] 64 | tell [LABEL m] 65 | mlabel (Seqn []) = do tell [] 66 | mlabel (Seqn (c:cs)) = do mlabel c 67 | mlabel (Seqn cs) 68 | 69 | comp :: Prog -> Code 70 | comp prog = snd $ fst $ (runState $ runWriterT $ mlabel prog) 0 71 | -------------------------------------------------------------------------------- /C14/ParserCalc.hs: -------------------------------------------------------------------------------- 1 | import Text.Parsec 2 | import qualified Text.Parsec.Token as T 3 | import Text.Parsec.Language (emptyDef) 4 | 5 | lexer :: T.TokenParser () 6 | lexer = T.makeTokenParser emptyDef 7 | 8 | lexeme :: Parsec String () a -> Parsec String () a 9 | lexeme = T.lexeme lexer 10 | 11 | float :: Parsec String () Double 12 | float = T.float lexer 13 | 14 | chars :: Parsec String () [Char] 15 | chars = do 16 | c1 <- lexeme $ char 'a' 17 | c2 <- lexeme $ char 'b' 18 | return [c1,c2] 19 | 20 | float1 :: Parsec String () Double 21 | float1 = do 22 | f <- lexeme sign 23 | n <- T.float lexer 24 | return (f n) 25 | 26 | sign :: Num a => Parsec String () (a -> a) 27 | sign = (char '-' >> return negate) 28 | <|> (char '+' >> return id) 29 | <|> return id 30 | 31 | data Exp = Add Exp Exp | Mul Exp Exp | Val Double deriving (Eq,Show) 32 | 33 | {- 34 | parseExp :: Parsec String () Exp 35 | parseExp = do 36 | e1 <- parseExp 37 | char '+' 38 | e2 <- parseMul 39 | return (Add e1 e2) 40 | <|> parseMul 41 | -} 42 | eval (Val v) = v 43 | eval (Add e1 e2) = eval e1 + eval e2 44 | eval (Mul e1 e2) = eval e1 * eval e2 45 | 46 | parseExp :: Parsec String () Exp 47 | parseExp = do 48 | e1 <- parseMul 49 | e2 <- parseExp' 50 | case e2 of 51 | Nothing -> return e1 52 | Just e -> return (e e1) 53 | 54 | -- $Exp' ::= + Mul Exp'| epsilon$ 55 | 56 | parseExp' :: Parsec String () (Maybe (Exp -> Exp)) 57 | parseExp' = try (do 58 | char '+' 59 | e1 <- parseMul 60 | e2 <- parseExp' 61 | case e2 of 62 | Nothing -> return (Just (\e -> Add e e1)) 63 | Just e -> return (Just (\e' -> e (Add e' e1) ))) 64 | <|> (return Nothing ) 65 | 66 | -- $Mul ::= Num Mul'$ 67 | 68 | parseMul :: Parsec String () Exp 69 | parseMul = do 70 | e1 <- parseNum 71 | e2 <- parseMul' 72 | case e2 of 73 | Nothing -> return e1 74 | Just e -> return (e e1) 75 | 76 | -- $Mul' ::= * Num Mul' | epsilon$ 77 | 78 | parseMul' :: Parsec String () (Maybe (Exp -> Exp )) 79 | parseMul' = try (do 80 | char '*' 81 | e1 <- parseNum 82 | e2 <- parseMul' 83 | case e2 of 84 | Nothing -> return (Just (\e -> Mul e e1)) 85 | Just e -> return (Just (\e' -> e (Mul e' e1)))) <|> return Nothing 86 | 87 | -- $Num ::=\ (Exp)\ |\ Number$ 88 | 89 | parseNum :: Parsec String () Exp 90 | parseNum = try (do 91 | char '(' 92 | e1 <- parseExp 93 | char ')' 94 | return e1) <|> (do {num <- float1; return (Val num)}) 95 | 96 | calculate str = case runParser parseExp () "" str of 97 | Right exp -> eval exp 98 | Left _ -> error "error" 99 | -------------------------------------------------------------------------------- /C21/CountServer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DeriveAnyClass #-} 5 | 6 | module Main where 7 | 8 | import GHC.Generics 9 | import Data.Binary 10 | import Data.Rank1Typeable 11 | import Control.Monad 12 | 13 | import Control.Distributed.Process 14 | import Control.Distributed.Process.ManagedProcess as M 15 | import Control.Distributed.Process.Extras (ExitReason(..)) 16 | import Control.Distributed.Process.Extras.Time (Delay(..)) 17 | import Control.Distributed.Process.Closure 18 | import Control.Distributed.Process.Node as P (initRemoteTable, runProcess) 19 | import Control.Distributed.Process.Backend.SimpleLocalnet 20 | 21 | -- Experimental 22 | import Control.Concurrent (threadDelay) 23 | import System.Environment 24 | import Control.Distributed.Backend.P2P as P2P 25 | 26 | data CountingCommand = AddOne | SetCount Int 27 | deriving (Generic, Typeable, Binary) 28 | data InfoCommand = GetCount | GetCountSquare 29 | deriving (Generic, Typeable, Binary) 30 | data ControlCommand = ExitServer 31 | deriving (Generic, Typeable, Binary) 32 | 33 | data CountServer = CountServer 34 | { countServerPid :: ProcessId 35 | , countingCmdPort :: ControlPort CountingCommand } 36 | 37 | newCountServer :: Process CountServer 38 | newCountServer = do 39 | (sp, rp) <- newChan 40 | CountServer 41 | <$> spawnLocal (server sp) 42 | <*> receiveChan rp 43 | 44 | addOne :: CountServer -> Process () 45 | addOne s = sendControlMessage (countingCmdPort s) AddOne 46 | 47 | setCount :: CountServer -> Int -> Process () 48 | setCount s c = sendControlMessage (countingCmdPort s) (SetCount c) 49 | 50 | getCount :: CountServer -> Process Int 51 | getCount s = M.call (countServerPid s) GetCount 52 | 53 | getCountSquare :: CountServer -> Process Int 54 | getCountSquare s = M.call (countServerPid s) GetCountSquare 55 | 56 | exitServer :: CountServer -> Process () 57 | exitServer s = cast (countServerPid s) ExitServer 58 | 59 | getCountRpcChan :: CountServer -> Process Int 60 | getCountRpcChan s = syncCallChan (countServerPid s) GetCount 61 | 62 | server :: SendPort (ControlPort CountingCommand) -> Process () 63 | server sp = do 64 | cc <- newControlChan 65 | sendChan sp $ channelControlPort cc 66 | 67 | let myDef = defaultProcess 68 | { apiHandlers = 69 | [ handleControlChan cc handleCounting 70 | , handleCallFrom handleInfo 71 | , handleCast_ $ \ExitServer -> stop_ ExitNormal 72 | , handleRpcChan $ \s chan GetCount -> sendChan chan s >> continue s ] 73 | , shutdownHandler = \s r -> say $ "[Stopped] count: " ++ show s ++ ", reason: " ++ show r 74 | , unhandledMessagePolicy = Log 75 | } 76 | serve () (\() -> return $ InitOk (0 :: Int) Infinity) myDef 77 | where 78 | handleCounting s AddOne = continue (succ s) 79 | handleCounting s (SetCount ns) = continue ns 80 | handleInfo s _ GetCount = reply s s 81 | handleInfo s ref GetCountSquare = do 82 | void $ spawnLocal $ do 83 | liftIO $ putStrLn "now calculating..." 84 | replyTo ref (s * s) 85 | noReply_ s 86 | 87 | main :: IO () 88 | main = do 89 | backend <- initializeBackend "localhost" "2000" $ __remoteTable initRemoteTable 90 | node <- newLocalNode backend 91 | P.runProcess node $ do 92 | pid <- spawnLocal server 93 | addOne pid 94 | addOne pid 95 | getCount pid >>= liftIO . print 96 | setCount pid 1 97 | getCount pid >>= liftIO . print 98 | -------------------------------------------------------------------------------- /C08/DataType.hs: -------------------------------------------------------------------------------- 1 | -- DataType.hs 2 | 3 | data Day = Mon | Tue | Wed | Thu | Fri | Sat | Sun 4 | deriving (Show,Read, Eq,Ord,Enum) 5 | {- 6 | tomorrow :: Day -> Day 7 | tomorrow Mon = Tue 8 | tomorrow Tue = Wed 9 | tomorrow Wed = Thu 10 | tomorrow Thu = Fri 11 | tomorrow Fri = Sat 12 | tomorrow Sat = Sun 13 | tomorrow Sun = Mon 14 | -} 15 | 16 | tomorrow Sun = Mon 17 | tomorrow d = succ d 18 | 19 | yesterday Mon = Sun 20 | yesterday d = pred d 21 | 22 | type Name = String 23 | type Author = String 24 | type ISBN = String 25 | type Price = Float 26 | 27 | data Book = Book { 28 | name :: Name, 29 | author :: Author, 30 | isbn :: ISBN, 31 | price :: Price 32 | } 33 | {- 34 | incrisePrice (b1,b2) b pri = 35 | ((b:b1),Book (name b) (author b) (isbn b) (price b + pri)) 36 | -} 37 | {- 38 | incrisePrice (b1,b2) (Book nm ath isbn prc) pri = 39 | ((Book nm ath isbn prc):b1 ,(Book nm ath isbn (prc+pri)):b2) 40 | -} 41 | 42 | {- 43 | increasePrice (b1,b2) b@(Book nm ath isbn prc) pri = 44 | (b:b1,(Book nm ath isbn (prc+pri)):b2) 45 | -} 46 | 47 | increasePrice :: ([Book], [Book]) -> Book -> Price -> ([Book], [Book]) 48 | increasePrice (b1,b2) b pri = (b:b1, (b{price=pri}):b2) 49 | 50 | data Pair a b = Pair a b 51 | 52 | pfirst (Pair a b) = a 53 | psecond (Pair a b) = b 54 | 55 | --------------------------------- 56 | --------------------------------- 57 | data Nat = Zero | Succ Nat deriving (Show,Eq,Ord) 58 | 59 | natToint :: Nat -> Int 60 | natToint Zero = 0 61 | natToint (Succ n) = 1 + natToint n 62 | 63 | int2nat :: Int -> Nat 64 | int2nat 0 = Zero 65 | int2nat n = Succ (int2nat (n-1)) 66 | 67 | {- 68 | add :: Nat -> Nat -> Nat 69 | add Zero n = n 70 | add (Succ m) n = Succ (add m n) 71 | -} 72 | 73 | add :: Nat -> Nat -> Nat 74 | add Zero n = n 75 | add (Succ m) n = add m (Succ n) 76 | 77 | --------------------------------- 78 | --------------------------------- 79 | data Shape = Circle { 80 | radius :: Float 81 | } | Rect { 82 | len :: Float, 83 | width :: Float 84 | } deriving (Show,Eq) 85 | 86 | area :: Shape -> Float 87 | area (Circle r) = pi * r^2 88 | area (Rect a b) = a * b 89 | 90 | data Person = Person { 91 | pname :: String, 92 | age :: Int, 93 | sex :: Bool } 94 | 95 | showPerson :: Person -> String 96 | showPerson (Person {pname = str, sex = s}) = str ++ show s 97 | 98 | 99 | data BoolExp = TRUE | FALSE | IF BoolExp BoolExp BoolExp deriving (Show,Eq) 100 | 101 | eval :: BoolExp -> Bool 102 | eval TRUE = True 103 | eval FALSE = False 104 | eval (IF con b1 b2) | eval con == True = eval b1 105 | | eval con == False = eval b2 106 | 107 | eval' :: [BoolExp] -> Bool 108 | eval' [TRUE] = True 109 | eval' [FALSE] = False 110 | eval' ((IF TRUE b1 b2):xs) = eval' (b1:xs) 111 | eval' ((IF FALSE b1 b2):xs) = eval' (b2:xs) 112 | eval' (l@(IF con b1 b2):xs) = eval' (con:l:xs) 113 | eval' (TRUE:(IF con b1 b2):xs) = eval' (b1:xs) 114 | eval' (FALSE:(IF con b1 b2):xs) = eval' (b2:xs) 115 | 116 | test = IF (IF FALSE FALSE TRUE) (IF FALSE TRUE FALSE) FALSE 117 | 118 | --------------------------------- 119 | --------------------------------- 120 | data List a = Nil | Cons a (List a) deriving (Eq,Show) 121 | 122 | mylistToList Nil = [] 123 | mylistToList (Cons x xs) = x:(mylistToList xs) 124 | 125 | listToMylist [] = Nil 126 | listToMylist (x:xs) = Cons x (listToMylist xs) -------------------------------------------------------------------------------- /C18/DeriveTopdown.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module DeriveTopdown (deriveTopdown, derivings) where 3 | import Language.Haskell.TH 4 | import Control.Monad.State 5 | import Control.Monad.Trans (lift) 6 | import Data.List (foldl') 7 | import qualified GHC.Generics as G 8 | 9 | getTyVarCons :: Name -> Q ([TyVarBndr], [Con]) 10 | getTyVarCons name = do 11 | info <- reify name 12 | case info of 13 | TyConI dec -> 14 | case dec of 15 | DataD _ _ tvbs cons _ -> return (tvbs,cons) 16 | NewtypeD _ _ tvbs con _ -> return (tvbs,[con]) 17 | TySynD _ vars type' -> undefined 18 | _ -> error "must be a data, newtype definition" 19 | _ -> error "bad type name, quoted name is not a type!" 20 | 21 | getTypeNames :: Type -> [Name] 22 | getTypeNames (ConT n) = [n] 23 | getTypeNames (AppT t1 t2) = getTypeNames t1 ++ getTypeNames t2 24 | getTypeNames _ = [] 25 | 26 | third (a,b,c) = c 27 | 28 | getCompositeType :: Con -> [Name] 29 | getCompositeType (NormalC n sts) = concatMap getTypeNames (map snd sts) 30 | getCompositeType (RecC n vars) = concatMap getTypeNames (map third vars) 31 | getCompositeType (InfixC st1 n st2) = concatMap getTypeNames [snd st1, snd st2] 32 | getCompositeType _ = undefined 33 | 34 | getTVBName :: TyVarBndr -> Name 35 | getTVBName (PlainTV name ) = name 36 | getTVBName (KindedTV name _) = name 37 | 38 | -- 假想我们要为(A a b G)类型生成Eq类型类的实例，即cn为''Eq，tn为''A 39 | gen :: Name -> Name -> StateT [Type] Q [Dec] 40 | gen cn tn = do 41 | -- 得到所需要的类型变量与构造器 42 | (tvbs,cons) <- lift $ getTyVarCons tn 43 | let typeNames = map getTVBName tvbs 44 | -- 然后使用把''A, a, b, G应用起来变成(A a b G) 45 | instanceType <- lift $ foldl' appT (conT tn) $ map varT typeNames 46 | -- 接下来生成所需要的上下为，Eq a, Eq b ..... 47 | let context = if cn == ''G.Generic -- Generic实例的生成不需要这个上下文 48 | then [] 49 | -- 会得到[Eq a, Eq b] 50 | else (map (AppT (ConT cn)) (map VarT typeNames)) 51 | -- 把context放到一个元组中(Eq a , Eq b , ...) 52 | let context_in_tuple = foldl1 AppT $ (TupleT (length context)) : context 53 | -- 判断该类型是不是已经为cn的实例 54 | isMember <- if tvbs == [] 55 | then lift $ isInstance cn [instanceType] 56 | -- 下面的代码并不会工作\footnote{这主要是由于\api{}中{\nc{isInstance}}的实现没有考虑类型类上下文，比如我们请求{\nc{Eq a => Eq [a]}}是不是{\nc{Eq}}类型类的实例结果会是{\nc{False}}，但对于我们这个简单的实现影响不大。} 57 | else lift $ isInstance cn [ForallT tvbs [] instanceType] 58 | -- 从状态Monad中取出已经生成过的类型 59 | table <- get 60 | -- 如果tn已经为cn的实例或者已经生成过了就不返回任何结果 61 | if isMember || elem instanceType table 62 | then return [] 63 | -- 否则返回这个类型类实例的声明，并把新生成的类型用modify函数加入到状态中去 64 | -- standalone driving: deriving instance (Eq a , Eq b) => Eq (A a b G) 65 | else do 66 | let c = [StandaloneDerivD [context_in_tuple] (AppT (ConT cn) instanceType)] 67 | modify (instanceType:) 68 | -- 得到这个数据构造器需要的类型，也就是A a b C中的C 69 | let names = concatMap getCompositeType cons 70 | -- 递归地向下生成该类型类的实例 71 | xs <- mapM (\n -> gen cn n) names 72 | return $ concat xs ++ c 73 | 74 | deriveTopdown :: Name -> Name -> Q [Dec] 75 | deriveTopdown cn tn = evalStateT (gen cn tn) [] 76 | 77 | derivings :: [Name] -> Name -> Q [Dec] 78 | derivings cnms t = fmap concat (sequenceA $ map (\x -> deriveTopdown x t) cnms) 79 | -------------------------------------------------------------------------------- /C14/Calculator.hs: -------------------------------------------------------------------------------- 1 | import Text.Parsec 2 | import qualified Text.Parsec.Token as T 3 | import Text.ParserCombinators.Parsec.Language 4 | import Text.Parsec.String 5 | 6 | data Exp = Plus Exp Exp | Minu Exp Exp | Mult Exp Exp | Divi Exp Exp 7 | | Power Exp Exp | Nega Exp | Posi Exp | Sqrt Exp |Log Exp | Ln Exp 8 | | Sin Exp | Cos Exp | Val Double deriving (Eq , Show) 9 | 10 | eval :: Exp -> Double 11 | eval (Plus e1 e2) = eval e1 + eval e2 12 | eval (Minu e1 e2) = eval e1 - eval e2 13 | eval (Mult e1 e2) = eval e1 * eval e2 14 | eval (Divi e1 e2) = eval e1 / eval e2 15 | eval (Power e1 e2) = eval e1 ** eval e2 16 | eval (Nega e1) = negate $ eval e1 17 | eval (Posi e1) = eval e1 18 | eval (Log e1) = logBase 2 (eval e1) 19 | eval (Ln e1) = log $ eval e1 20 | eval (Sin e1) = sin $ eval e1 21 | eval (Cos e1) = cos $ eval e1 22 | eval (Sqrt e) = sqrt $ eval e 23 | eval (Val e) = e 24 | 25 | lexer :: T.TokenParser () 26 | lexer = T.makeTokenParser emptyDef 27 | 28 | lexeme :: Parsec String () a -> Parsec String () a 29 | lexeme = T.lexeme lexer 30 | 31 | constant :: Parsec String () Double 32 | constant = do 33 | choice [lexeme $ string "pi" >> return 3.1415926, 34 | lexeme $ string "e" >> return 2.71828 ] 35 | 36 | float :: Parsec String () Double 37 | float = do 38 | n <- T.float lexer 39 | return n 40 | 41 | number :: Parsec String () Double 42 | number = try (do 43 | int <- T.integer lexer 44 | return (fromIntegral int)) <|> try float <|> constant 45 | 46 | parseExp :: Parser Exp 47 | parseExp = do 48 | e1 <- parseMul 49 | e2 <- parseExp' 50 | case e2 of 51 | Nothing -> return e1 52 | Just e -> return (e e1) 53 | 54 | parseExp' :: Parser (Maybe (Exp -> Exp)) 55 | parseExp' = do 56 | (lexeme.char) '+' 57 | e1 <- parseMul 58 | e2 <- parseExp' 59 | case e2 of 60 | Nothing -> return (Just (\e -> Plus e e1)) 61 | Just e -> return (Just (\e' -> e (Plus e' e1))) 62 | <|> 63 | do 64 | (lexeme.char) '-' 65 | e1 <- parseMul 66 | e2 <- parseExp' 67 | case e2 of 68 | Nothing -> return (Just (\e -> Minu e e1)) 69 | Just e -> return (Just (\e' -> e (Minu e' e1))) 70 | <|> 71 | return Nothing 72 | 73 | parseMul :: Parser Exp 74 | parseMul = do 75 | e1 <- parseUExp 76 | e2 <- parseMul' 77 | case e2 of 78 | Nothing -> return e1 79 | Just e -> return (e e1) 80 | 81 | parseMul' :: Parsec String () (Maybe (Exp -> Exp)) 82 | parseMul' = do 83 | (lexeme.char) '*' 84 | e1 <- parseUExp 85 | e2 <- parseMul' 86 | case e2 of 87 | Nothing -> return (Just (\e -> Mult e e1)) 88 | Just e -> return (Just (\e'-> e (Mult e' e1))) 89 | <|> 90 | do 91 | (lexeme.char) '/' 92 | e1 <- parseUExp 93 | e2 <- parseMul' 94 | case e2 of 95 | Nothing -> return (Just (\e -> Divi e e1)) 96 | Just e -> return (Just (\e'-> e (Divi e' e1))) 97 | <|> 98 | return Nothing 99 | 100 | parseUExp :: Parser Exp 101 | parseUExp = do 102 | op <- choice (map (try.lexeme.string) 103 | ["-","+","log","ln","sin","sqrt","cos"]) 104 | e1 <- parseUExp 105 | case op of 106 | "-" -> return $ Nega e1 107 | "+" -> return $ Posi e1 108 | "sqrt" -> return $ Sqrt e1 109 | "log" -> return $ Log e1 110 | "ln" -> return $ Ln e1 111 | "sin" -> return $ Sin e1 112 | "cos" -> return $ Cos e1 113 | _ -> fail "expect an unary operator" 114 | <|> parsePower 115 | 116 | 117 | parsePower :: Parser Exp 118 | parsePower = try (do 119 | num <- parseNum 120 | lexeme $ char '^' 121 | e1 <- parsePower 122 | return (Power num e1)) 123 | <|> parseNum 124 | 125 | parseNum :: Parser Exp 126 | parseNum = try (do 127 | lexeme $ char '(' 128 | e1 <- parseExp 129 | lexeme $ char ')' 130 | return e1) <|> 131 | do 132 | num<- number 133 | return (Val num) 134 | -------------------------------------------------------------------------------- /C23/SF.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows,DeriveFunctor #-} 2 | import Control.Arrow 3 | import Control.Category 4 | import Prelude hiding (id,(.)) 5 | import qualified Prelude as Prelude 6 | 7 | 8 | data SF a b = SF {runSF :: [a] -> [b]} 9 | 10 | instance Category SF where 11 | id = SF (Prelude.id) 12 | (.) (SF f) (SF g) = SF ((Prelude..) f g) 13 | 14 | instance Arrow SF where 15 | arr f = SF (map f) 16 | -- f :: [b] -> [c] 17 | -- bd :: [(b,d)] 18 | -- res :: [(c,d)] 19 | first (SF f) = SF $ \bd -> let (bs,ds) = unzip bd 20 | in zip (f bs) ds 21 | 22 | class ArrowLoop a => ArrowCircuit a where 23 | delay :: b -> a b b 24 | 25 | instance ArrowCircuit SF where 26 | delay x = SF (init. (x:)) 27 | 28 | mapA' :: SF b c -> SF [b] [c] 29 | mapA' (SF f) = SF (\xs -> map f xs) 30 | 31 | instance ArrowChoice SF where 32 | left (SF f) = SF (\xs -> combine xs (f [y | Left y <- xs])) 33 | where combine (Left y:xs) (z:zs) = Left z: combine xs zs 34 | combine (Right y:xs) zs = Right y: combine xs zs 35 | combine [] zs = [] 36 | 37 | listcase [] = Left () 38 | listcase (x:xs) = Right (x,xs) 39 | 40 | mapA :: ArrowChoice a => a b c -> a [b] [c] 41 | mapA f = arr listcase >>> 42 | arr (const []) ||| (f *** mapA f >>> arr (uncurry (:))) 43 | 44 | mapA'' :: ArrowChoice a => a b c -> a [b] [c] 45 | mapA'' f = proc xs -> do 46 | case xs of 47 | [] -> returnA -< [] 48 | (x:xs') -> do 49 | y <- f -< x 50 | ys <- mapA f -< xs' 51 | returnA -< y:ys 52 | 53 | instance ArrowLoop SF where 54 | -- f :: [(b,d)] -> [(c,d)] 55 | -- as :: [b] 56 | loop (SF f) = SF $ \as -> 57 | let (bs,cs) = unzip (f (zip as (stream cs))) in bs 58 | where stream ~(x:xs) = x:stream xs 59 | 60 | showBools :: [Bool] -> String 61 | showBools [] = "" 62 | showBools (False : xs) = '_' : showBools xs 63 | showBools (True : xs) = '^' : showBools xs 64 | 65 | toBools :: String -> [Bool] 66 | toBools "" = [] 67 | toBools ('_': xs) = False : toBools xs 68 | toBools ('^': xs) = True: toBools xs 69 | toBools _ = error "only ^ and _ can be used." 70 | 71 | s1 ,s2:: [Bool] 72 | s1 = toBools "____^^^^^____^^^^^____" 73 | s2 = toBools "_^_^_^_^_^_^_^_^_^_^_^" 74 | s3 = toBools "^^^^^^^^^^^^^^^^^^^^^^" 75 | s4 = toBools "______________________" 76 | s5 = toBools "__________^___________" 77 | 78 | edge :: SF Bool Bool 79 | edge = arr id &&& delay False >>> arr detect 80 | where detect (a,b) = a && not b 81 | 82 | edge' :: SF Bool Bool 83 | edge' = proc b -> do 84 | c <- delay False -< b 85 | returnA -< b && not c 86 | 87 | nor :: SF (Bool,Bool) Bool 88 | nor = arr (not.uncurry (||)) 89 | 90 | counter :: ArrowCircuit a => a Bool Int 91 | counter = proc reset -> do 92 | rec output <- returnA -< if reset then 0 else next 93 | next <- delay 1 -< output + 1 94 | returnA -< output 95 | 96 | counter' :: ArrowCircuit a => a Bool Int 97 | counter' = loop (arr (\(reset, next) -> 98 | dup (if reset then 0 else next)) >>> 99 | (first (arr (+1) >>> delay 1) >>> aswap)) 100 | 101 | dup :: Arrow arrow => arrow a (a,a) 102 | dup = arr $ \a -> (a,a) 103 | 104 | aswap :: Arrow a => a (b,c) (c,b) 105 | aswap = arr $ \(a,b) -> (b,a) 106 | 107 | flipflop :: SF (Bool, Bool) (Bool, Bool) 108 | flipflop = loop (arr (\((reset,set),(c,d)) -> ((set,d),(reset,c))) >>> 109 | nor *** nor >>> 110 | delay (False,True) >>> -- reset 111 | arr id &&& arr id) 112 | 113 | flipflop' :: SF (Bool, Bool) (Bool, Bool) 114 | flipflop' = proc (reset,set) -> do 115 | rec c <- delay False -< nor' reset d 116 | d <- delay True -< nor' set c 117 | returnA -< (c,d) 118 | where nor' a b = not (a || b) 119 | 120 | -- bimap showBools showBools (unzip (runSF flipflop' (zip s1 s2))) 121 | -- let (r1,r2) = bimap showBools showBools (unzip (runSF flipflop' (zip s1 s2))) in putStrLn r1 >> putStrLn r2 122 | 123 | parB :: Arrow arr => [arr a b] -> arr a [b] 124 | parB [] = arr $ \_ -> [] 125 | parB (x:xs) = proc a -> do 126 | b <- x -< a 127 | bs <- parB xs -< a 128 | returnA -< b:bs 129 | -------------------------------------------------------------------------------- /C14/Parser.hs: -------------------------------------------------------------------------------- 1 | import Control.Applicative 2 | import Data.Char 3 | 4 | type Line = Int 5 | type Column = Int 6 | 7 | data Pos = Pos { getLine :: Line , 8 | getColumn :: Column } deriving (Eq,Show) 9 | 10 | updatePos :: Pos -> Char -> Pos 11 | updatePos (Pos l c) char = 12 | case char of 13 | '\n' -> Pos (l+1) 1 14 | '\t' -> Pos l ((c+8-(c-1) `mod` 8)) 15 | _ -> Pos l (c+1) 16 | 17 | initialPos :: Pos 18 | initialPos = Pos 1 1 19 | 20 | data State s = State { stateInput :: s , statePos :: Pos } 21 | deriving (Eq,Show) 22 | 23 | data Reply s a = Ok a (State s) ParseError | Error ParseError deriving (Eq,Show) 24 | 25 | data Message = Info String | Warn String | Err String deriving (Eq,Show) 26 | 27 | data ParseError = ParseError [Message] deriving (Eq,Show) 28 | 29 | appendError :: ParseError -> Message -> ParseError 30 | appendError (ParseError a) msg = ParseError (msg:a) 31 | 32 | data Consumed a = Consumed a 33 | | Empty a 34 | 35 | data Parser s a = 36 | Parser { runParser :: State s -> ParseError -> Consumed (Reply s a) } 37 | 38 | instance Functor (Parser s) where 39 | fmap f p = Parser $ \st error -> case runParser p st error of 40 | Consumed (Ok r st' err) -> Consumed (Ok (f r) st' err) 41 | Consumed (Error err) -> Consumed (Error err) 42 | Empty (Ok r st' err) -> Empty (Ok (f r) st' err) 43 | Empty (Error err) -> Empty (Error err) 44 | 45 | instance Monad (Parser s) where 46 | return inp = Parser $ \st error -> Empty (Ok inp st error) 47 | p >>= f = Parser $ \st error -> case runParser p st error of 48 | Consumed (Ok r st' err) -> runParser (f r) st' err 49 | Consumed (Error err) -> Consumed (Error err) 50 | Empty (Ok r st' err) -> runParser (f r) st' err 51 | Empty (Error err) -> Empty (Error err) 52 | 53 | instance Applicative (Parser s) where 54 | pure = return 55 | (<*>) pf pa = do 56 | f <- pf 57 | m <- pa 58 | return $ f m 59 | 60 | instance Alternative (Parser s) where 61 | empty = Parser $ \st err -> Empty (Error err) 62 | p <|> q = Parser $ \st err -> case runParser p st err of 63 | Empty (Error err') -> runParser q st err 64 | Empty o@(Ok r st' err') -> case runParser q st err of 65 | Empty _ -> Empty o 66 | consumed-> consumed 67 | consumed -> consumed 68 | 69 | () :: Parser s a -> Message -> Parser s a 70 | () p msg = Parser $ \st err -> case runParser p st err of 71 | Empty (Error err') -> 72 | Empty (Error (appendError err' msg)) 73 | Consumed (Error err') -> 74 | Consumed (Error (appendError err' msg)) 75 | result -> result 76 | 77 | satisfy :: (Char -> Bool) -> Parser String Char 78 | satisfy f = Parser $ \(State str pos) err -> 79 | case str of 80 | c:cs -> if f c 81 | then Consumed 82 | (Ok c (State cs (updatePos pos c)) err) 83 | else Empty 84 | (Error (ParseError [Err ("error at " ++ 85 | show pos)])) 86 | [] -> Empty 87 | (Error (ParseError [Err ("error at " ++ 88 | show pos ++ 89 | " input exausted.")])) 90 | 91 | char :: Char -> Parser String Char 92 | char c = satisfy (==c) Info ("expect a character " ++ show c) 93 | 94 | letter :: Parser String Char 95 | letter = satisfy isAlpha Info "expect an alpha" 96 | 97 | string :: String -> Parser String String 98 | string [] = return [] 99 | string (s:str) = do 100 | c <- char s 101 | cs <- string str 102 | return (c:cs) 103 | 104 | parse :: String -> Parser String a -> a 105 | parse str p = case runParser p (State str initialPos) (ParseError []) of 106 | Consumed (Ok r st' err) -> r 107 | Consumed (Error err) -> error $ show err 108 | Empty (Ok r st err) -> r 109 | Empty (Error err) -> error $ show err 110 | -------------------------------------------------------------------------------- /C24/ContinuationFRP.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | 3 | module ContinuationFRP where 4 | import Control.Arrow 5 | import Control.Category 6 | import Prelude hiding ((.) , id) 7 | 8 | type Time = Double 9 | type DTime = Double 10 | 11 | data SF a b = MkSF {runSF :: a -> DTime -> (b,SF a b)} 12 | 13 | runSFs :: [SF a b] -> a -> DTime -> [(b,SF a b)] 14 | runSFs sfs a dt = map f sfs 15 | where 16 | -- f :: SF a b -> (b,SF a b) 17 | f sf = runSF sf a dt 18 | 19 | reactimate :: IO a -> IO DTime -> (b -> Bool) -> (b -> IO ()) -> SF a b -> IO () 20 | reactimate getInput getTick terminate putOutput sf0 = loop sf0 21 | where 22 | -- loop :: SF a b -> IO () 23 | loop sf = do a <- getInput 24 | dt <- getTick 25 | let (b,sf') = runSF sf a dt 26 | putOutput b 27 | if terminate b 28 | then return () 29 | else loop sf' 30 | 31 | integral :: Double -> SF Double Double 32 | integral v0 = MkSF (\a dt -> let v = a * dt + v0 33 | in (v, integral v)) 34 | 35 | instance Category SF where 36 | id = MkSF $ \a -> \t -> (a, id) 37 | sf2 . sf1 = MkSF (\a dt -> let (b,sf1') = runSF sf1 a dt 38 | (c,sf2') = runSF sf2 b dt 39 | in (c,sf2' . sf1')) 40 | 41 | instance Arrow SF where 42 | arr f = MkSF (\a _ -> let b = f a 43 | in (b,arr f)) 44 | -- f :: SF b c = b -> DTime -> (c , SF b c) 45 | -- res :: (b,d) -> DTime -> ((c,d), SF (b,d) (c,d)) 46 | first f = MkSF $ \(b,d) -> \dt -> let (c,sf1) = runSF f b dt 47 | in ((c,d), first sf1) 48 | 49 | instance ArrowChoice SF where 50 | -- f :: SF b c = b -> DTime -> (c, SF b c) 51 | -- res :: (Either b d) -> DTime -> (Either c d, SF (Either b d) (Either c d)) 52 | left sf@(MkSF f) = MkSF $ \r -> \dt -> case r of 53 | Left a -> let (r,sf1) = f a dt in (Left r, left sf1) 54 | Right b -> (Right b, left sf) 55 | 56 | instance ArrowLoop SF where 57 | loop sf@(MkSF f) = MkSF $ \b -> \dt -> 58 | let (~(c,d), sf') = f (b,d) dt in (c, loop sf') 59 | 60 | sinSF :: SF Double Double 61 | sinSF = MkSF (\d dt -> (sin (d + dt), (\x -> x + dt) ^>> sinSF)) 62 | 63 | data Event v = NoEvent | AnEvent v 64 | deriving (Show, Functor) 65 | 66 | edge :: (a -> Bool) -> SF a (Event a) 67 | edge p = edgeAux True 68 | where 69 | -- edgeAux :: Bool -> SF a Event 70 | edgeAux b = MkSF (\ a _ -> let q = p a 71 | e = if q && (not b) then AnEvent a else NoEvent 72 | sf = if q then edgeAux True else edgeAux False 73 | in (e,sf)) 74 | 75 | edgeTest = sinSF >>> edge (> 0) 76 | 77 | parB :: [SF a b] -> SF a [b] 78 | parB sfs = MkSF (\ a dt -> let bsfs = runSFs sfs a dt 79 | (bs,sfs') = unzip bsfs 80 | in (bs, parB sfs')) 81 | 82 | constant :: b -> SF a b 83 | constant b = MkSF (\ _ _ -> (b,constant b)) 84 | 85 | localTime :: SF a Time 86 | localTime = constant 1 >>> integral 0 87 | 88 | after :: Time -> SF a (Event Time) 89 | after t = localTime >>> edge (>= t) 90 | 91 | switch :: SF a b -> SF b (Event v) -> (v -> SF a b) -> SF a b 92 | switch sf1 sfe f = MkSF (\ a dt -> let (b, sf1') = runSF sf1 a dt 93 | (ev, sfe') = runSF sfe b dt 94 | sf' = case ev of 95 | NoEvent -> switch sf1' sfe' f 96 | AnEvent v -> f v 97 | in (b,sf')) 98 | 99 | switch' :: SF () b -> (v -> b -> SF (Event v) b) -> SF (Event v) b 100 | switch' sf1 f = MkSF (\ ev dt -> let (b,sf1') = runSF sf1 () dt 101 | sf' = case ev of 102 | NoEvent -> switch' sf1' f 103 | AnEvent v -> f v b 104 | in (b,sf')) 105 | 106 | pSwitch :: [SF a b] -> SF (a,Event (SF a b)) [b] 107 | pSwitch sfs = MkSF (\ (a,ev) dt -> let newSFs = case ev of 108 | NoEvent -> sfs 109 | AnEvent newSF -> newSF : sfs 110 | bsfs = runSFs newSFs a dt 111 | (bs,sfs') = unzip bsfs 112 | in (bs, pSwitch sfs')) 113 | 114 | -------------------------------------------------------------------------------- /C17/Generic0.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, 2 | TypeOperators, 3 | TypeFamilies, 4 | FlexibleContexts, 5 | DefaultSignatures #-} 6 | 7 | data T a b = Q | N a b deriving Show 8 | 9 | 10 | data Choice = I Int 11 | | C Char 12 | | B Choice Bool 13 | | S Choice deriving Show 14 | 15 | instance (Eq a , Eq b ) => Eq (T a b) where 16 | Q == Q = True 17 | (N x1 y1)== (N x2 y2) = x1 == x2 && y1 == y2 18 | _ == _ = False 19 | 20 | instance Eq Choice where 21 | (I i1) == (I i2) = i1 == i2 22 | (C c1) == (C c2) = c1 == c2 23 | (B c1 b1) == (B c2 b2) = c1 == c2 && b1 == b2 24 | (S c1) == (S c2) = c1 == c2 25 | _ == _ = False 26 | 27 | data Tree a = Leaf a | Node (Tree a) (Tree a) 28 | 29 | instance Eq a => (Eq (Tree a)) where 30 | Leaf a1 == Leaf a2 = a1 == a2 31 | (Node n1 n2) == (Node n3 n4) = n1 == n3 && n2 == n4 32 | _ == _ = False 33 | 34 | data Rose a = Fork a [Rose a] 35 | 36 | instance Eq a => Eq (Rose a) where 37 | (Fork a as) == (Fork b bs) = a == b && as == bs 38 | 39 | {- Make sure that you can find the patterns for writing instances of Eq type class. 40 | A pattern for implementing Eq class: 41 | 1, For each constructor, we introduce each parameter(field) of which such that we can check the equalities of its parameters(fields) respectively and combine the result by (&&). 42 | 2, For the other cases, i.e. the constructor are not the same, we just return False 43 | -} 44 | -- Surely, this can be implemented automatically. 45 | -- The idea is to fulfil the generalization of algebric data types 46 | 47 | data U = U deriving Show -- () 48 | -- | product (a,b) :*: in GHC.Generic 49 | data a :*: b = a :*: b deriving (Show, Eq) 50 | -- | sum (Left a | Right b) :+: in GHC.Generic 51 | data a :+: b = L a | R b deriving (Show, Eq) 52 | 53 | -- Haskell can generate Generic instances automatically by using driving keyword. 54 | -- Generic has kind * -> Constraint. More generally, it should have a polymorphic kind, i.e. k -> Constraint, 55 | -- since you need to derive some type classes with 1 or more type parameter like the Typeable class. 56 | -- However, the designer doesn't do this since he thinks generating class instances with two more parameters 57 | -- automatically is rare. 58 | 59 | -- Therefore with the following you can derive type class with kind * -> Constraint such as Eq, Show, etc. 60 | -- but not (* -> *) -> Constraint 61 | class Generic a where 62 | type Rep a :: * -- more generally it should have * -> * . See Generic1 63 | from :: a -> Rep a 64 | to :: Rep a -> a 65 | 66 | {- With the following Generic1 class, you can define functors, foldable classes. 67 | We will discuss it next time. 68 | class Generic1 a where 69 | type Rep1 a :: * -> * 70 | from1 :: a -> Rep1 a p 71 | to1 :: Rep1 a p -> a 72 | and if you want to derive Bifunctor, it will be out of capability of GHC.Generic. 73 | Like I said, this is possible, but the designer doesn't want to complicate the design. 74 | You can do it your self. 75 | -} 76 | instance Generic Bool where 77 | type Rep Bool = U :+: U 78 | from False = L U 79 | from True = R U 80 | to (L U) = False 81 | to (R U) = True 82 | 83 | 84 | -- data [] a = [] | a : [a] 85 | instance Generic [a] where 86 | type Rep [a] = U :+: (a :*: [a]) 87 | from [] = L U 88 | from (x:xs) = R (x :*: xs) 89 | to (L U) = [] 90 | to (R (x:*:xs)) = x:xs 91 | 92 | -- write instance for Rose tree by yourself 93 | 94 | -- This part should be written by library designer. 95 | class GEq a where 96 | geq :: a -> a -> Bool 97 | -- For library user: 98 | -- You can give a default definition if the data 99 | -- type is an instance of Generic type class. 100 | -- Since the Generic instance can be generated 101 | -- by using deriving keyword in GHC, you do not 102 | -- need actually to implement it. All you need 103 | -- to do is to write deriving Generic and an empty 104 | -- GEq instance since the default function is in the class. 105 | 106 | -- For library designer: 107 | -- You need to define the instances for the type class 108 | -- you need to define for :*: , :+:, U, and the other type operators 109 | -- with the default functions. 110 | 111 | default geq :: (Generic a, GEq (Rep a)) => a -> a -> Bool 112 | geq = defaultEq 113 | 114 | instance (GEq a , GEq b) => GEq (a :+: b) where 115 | geq (L a1) (L a2) = geq a1 a2 116 | geq (R b1) (R b2) = geq b1 b2 117 | geq _ _ = False 118 | 119 | instance (GEq a, GEq b) => GEq (a :*: b) where 120 | geq (a1 :*: b1) (a2 :*: b2) = geq a1 a2 && geq b1 b2 121 | 122 | instance GEq U where 123 | geq U U = True 124 | 125 | instance GEq Bool 126 | 127 | defaultEq :: (Generic a , GEq (Rep a)) => a -> a -> Bool 128 | defaultEq x y = geq (from x) (from y) 129 | 130 | data List a = Nil | Cons a (List a) deriving Show 131 | -- Generated by the compiler 132 | instance Generic a => Generic (List a) where 133 | type Rep (List a) = U :+: (a :*: (List a)) 134 | from Nil = L U 135 | from (Cons x xs) = R (x :*: xs) 136 | to (L U) = Nil 137 | to (R (x :*: xs)) = Cons x xs 138 | -- Written by library users 139 | instance (GEq a , Generic a) => (GEq (List a)) 140 | -------------------------------------------------------------------------------- /C12/StackCalc/Calculator.hs: -------------------------------------------------------------------------------- 1 | module Calculator where 2 | import Control.Monad.State 3 | 4 | data Lit = Val Float | Const String | Empty deriving (Eq,Show) 5 | 6 | data Op = Posi | Nega | Plus | Minu 7 | | Mult | Divi | Power 8 | | Log | Ln | Sin | Cos | Sqrt 9 | | L_Par | R_Par 10 | | OpBottom 11 | deriving (Eq, Show) 12 | 13 | data Order = Unary | Binary | Null | Bottom 14 | 15 | nary :: Op -> Order 16 | nary op = case op of 17 | Plus -> Binary 18 | Minu -> Binary 19 | Mult -> Binary 20 | Divi -> Binary 21 | Power-> Binary 22 | Posi -> Unary 23 | Nega -> Unary 24 | Log -> Unary 25 | Ln -> Unary 26 | Sin -> Unary 27 | Cos -> Unary 28 | Sqrt -> Unary 29 | OpBottom -> Bottom 30 | _ -> Null 31 | 32 | priority :: Op -> Int 33 | priority op = case op of 34 | Plus -> 1 35 | Minu -> 1 36 | Mult -> 2 37 | Divi -> 2 38 | Log -> 3 39 | Sin -> 3 40 | Cos -> 3 41 | Posi -> 4 42 | Nega -> 4 43 | Sqrt -> 4 44 | Power-> 5 45 | _ -> 0 46 | 47 | type LitOp = Either Lit Op 48 | 49 | type Stack = ([LitOp],[LitOp]) 50 | 51 | evaluate :: Op -> LitOp -> LitOp -> State Stack () 52 | evaluate op (Left (Val f1)) (Left (Val f2)) = case op of 53 | Plus -> push $ lv (f1+f2) 54 | Minu -> push $ lv (f1-f2) 55 | Mult -> push $ lv (f1*f2) 56 | Divi -> push $ lv (f1/f2) 57 | Power-> push $ lv (f1**f2) 58 | evaluate op (Left (Val f1)) (Left Empty) = case op of 59 | Posi -> push $ lv f1 60 | Nega -> push $ lv (-f1) 61 | Log -> push $ lv (logBase 2 f1) 62 | Ln -> push $ lv (log f1) 63 | Sin -> push $ lv (sin f1) 64 | Cos -> push $ lv (cos f1) 65 | Sqrt -> push $ lv (sqrt f1) 66 | 67 | lv :: Float -> LitOp 68 | lv x = Left $ Val x 69 | 70 | pop0,pop1 :: State Stack LitOp 71 | pop0 = state $ \(ls,rs) -> case ls of 72 | [] -> error "Number stack underflow" 73 | (h:hs) -> (h,(hs,rs)) 74 | pop1 = state $ \(ls,rs) -> case rs of 75 | [] -> error "Operator stack underflow" 76 | (h:hs) -> (h,(ls,hs)) 77 | 78 | push :: LitOp -> State Stack () 79 | push (Left (Const "pi")) = push $ lv 3.1415926 80 | push (Left (Const "e" )) = push $ lv 2.7182812 81 | push (Left (Const c )) = error $ "Unkown Constant"++c 82 | push l@(Left a) = state $ \(ls,rs) -> ((), (l:ls,rs)) 83 | push r@(Right a) = state $ \(ls,rs) -> ((), (ls,r:rs)) 84 | 85 | pushIn :: LitOp -> State Stack () 86 | pushIn l@(Left num) = push l 87 | pushIn p@(Right L_Par) = push p 88 | pushIn p@(Right R_Par) = do 89 | Right top <- pop1 90 | case nary top of 91 | Null -> return () 92 | Unary -> do 93 | f1 <- pop0 94 | evaluate top f1 (Left Empty) 95 | pushIn p 96 | Binary-> do 97 | f1 <- pop0 98 | f2 <- pop0 99 | evaluate top f2 f1 100 | pushIn p 101 | Bottom -> error "Excepted Left Bracket\n" 102 | pushIn o@(Right op) = do 103 | case nary op of 104 | Unary -> push o 105 | Binary -> do 106 | Right top <- pop1 107 | case nary top of 108 | Unary -> do 109 | let pri = priority top > priority op in 110 | case pri of 111 | True -> do 112 | f1 <- pop0 113 | evaluate top f1 (Left Empty) 114 | pushIn o 115 | False -> do 116 | push (Right top) 117 | push o 118 | Binary -> do 119 | case op of 120 | Power -> do 121 | push (Right top) 122 | push o 123 | _ -> do 124 | let pri=priority top >= priority op 125 | case pri of 126 | True -> do 127 | f1 <- pop0 128 | f2 <- pop0 129 | evaluate top f2 f1 130 | pushIn (Right op) 131 | False -> do 132 | push (Right top) 133 | push o 134 | _ -> do --- L_Par and OpBottom 135 | push (Right top) 136 | push o 137 | calc :: [LitOp] -> State Stack LitOp 138 | calc [] = do 139 | Right op <- pop1 140 | case nary op of 141 | Bottom -> pop0 142 | Unary -> do 143 | f1 <- pop0 144 | evaluate op f1 (Left Empty) 145 | calc [] 146 | Binary -> do 147 | f1 <- pop0 148 | f2 <- pop0 149 | evaluate op f2 f1 150 | calc [] 151 | Null -> error "Excepted right bracket" 152 | 153 | calc (t:ts) = do 154 | pushIn t 155 | calc ts 156 | 157 | inits :: ([LitOp],[LitOp]) 158 | inits = ([], [Right OpBottom]) 159 | 160 | test1 = [Right Nega, Left (Const "pi")] 161 | 162 | test2 = [Right L_Par, Left (Val 5.0),Right Plus, Left (Val 6),Right R_Par, Right Mult, Left (Val 3.0)] -- (5+6)*3 163 | 164 | test3 = [Right Log , Right L_Par,Left (Val 8),Right Plus, Left (Val 8), Right R_Par, Right Plus , Left (Val 5)] -- log (8+8) + 5 165 | 166 | test4 = [Right Log ,Left (Val 8),Right Power, Left (Val 2), Right Plus , Left (Val 5)] -- log 8^2 + 5 167 | 168 | test5 = [Right Sqrt , Left (Val 4),Right Plus,Left (Val 4)] --sqrt 4 + 4 169 | 170 | -------------------------------------------------------------------------------- /C14/Iteratee.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | import Data.Function (fix) 3 | import Control.Monad 4 | import qualified Control.Exception as Exc 5 | import Control.Monad.IO.Class 6 | import Control.Monad.Trans 7 | 8 | data Stream a = Chunks [a] | EOF 9 | deriving (Show, Eq,Functor) 10 | 11 | instance Monoid (Stream a) where 12 | mempty = Chunks mempty 13 | mappend (Chunks xs) (Chunks ys) = Chunks (xs ++ ys) 14 | mappend _ _ = EOF 15 | 16 | instance Monad Stream where 17 | return = Chunks . return 18 | Chunks xs >>= f = mconcat (fmap f xs) 19 | EOF >>= _ = EOF 20 | 21 | instance Applicative Stream where 22 | pure = return 23 | (<*>) = ap 24 | 25 | data Step a m b 26 | = Continue (Stream a -> Iteratee a m b) 27 | | Yield b (Stream a) 28 | | Error Exc.SomeException 29 | deriving Functor 30 | 31 | newtype Iteratee a m b = Iteratee { runIteratee :: m (Step a m b)} 32 | deriving Functor 33 | 34 | instance Monad m => Monad (Iteratee a m) where 35 | return x = yield x (Chunks []) 36 | m0 >>= f = ($ m0) $ fix $ 37 | \bind m -> Iteratee $ runIteratee m >>= \r1 -> 38 | case r1 of 39 | Continue k -> return (Continue (bind . k)) 40 | Error err -> return (Error err) 41 | Yield x (Chunks []) -> runIteratee (f x) 42 | Yield x extra -> runIteratee (f x) >>= \r2 -> 43 | case r2 of 44 | Continue k -> runIteratee (k extra) 45 | Error err -> return (Error err) 46 | Yield x' _ -> return (Yield x' extra) 47 | 48 | instance Monad m => Applicative (Iteratee a m) where 49 | pure = return 50 | (<*>) = ap 51 | 52 | instance MonadTrans (Iteratee a) where 53 | lift m = Iteratee (m >>= runIteratee . return) 54 | 55 | instance MonadIO m => MonadIO (Iteratee a m) where 56 | liftIO = lift . liftIO 57 | 58 | returnI :: Monad m => Step a m b -> Iteratee a m b 59 | returnI step = Iteratee (return step) 60 | 61 | yield :: Monad m => b -> Stream a -> Iteratee a m b 62 | yield x extra = returnI (Yield x extra) 63 | 64 | continue :: Monad m => (Stream a -> Iteratee a m b) -> Iteratee a m b 65 | continue k = returnI (Continue k) 66 | 67 | enumEOF :: Monad m => Enumerator a m b 68 | enumEOF (Yield x _) = yield x EOF 69 | enumEOF (Error err) = returnI (Error err) 70 | enumEOF (Continue k) = k EOF >>== check where 71 | check (Continue _) = error "mEOF: divergent iteratee" 72 | check s = enumEOF s 73 | 74 | run :: Monad m => Iteratee a m b 75 | -> m (Either Exc.SomeException b) 76 | run i = do 77 | mStep <- runIteratee $ enumEOF ==<< i 78 | case mStep of 79 | Error err -> return $ Left err 80 | Yield x _ -> return $ Right x 81 | Continue _ -> error "run: divergent iteratee" 82 | 83 | run_ :: Monad m => Iteratee a m b -> m b 84 | run_ i = run i >>= either Exc.throw return 85 | 86 | type Enumerator a m b = Step a m b -> Iteratee a m b 87 | 88 | enumList :: Monad m => Int -> [a] -> Enumerator a m b 89 | enumList n = loop where 90 | loop xs (Continue k) | not (null xs) = let 91 | (s1, s2) = splitAt n xs 92 | in k (Chunks s1) >>== loop s2 93 | loop _ step = returnI step 94 | 95 | type Enumeratee ao ai m b = Step ai m b -> Iteratee ao m (Step ai m b) 96 | 97 | infixl 1 >>== 98 | infixr 1 ==<< 99 | infixr 0 $$ 100 | infixr 1 >==> 101 | infixr 1 <==< 102 | 103 | (>>==) :: Monad m 104 | => Iteratee a m b 105 | -> (Step a m b -> Iteratee a' m b') 106 | -> Iteratee a' m b' 107 | i >>== f = Iteratee (runIteratee i >>= runIteratee . f) 108 | 109 | (==<<) :: Monad m 110 | => (Step a m b -> Iteratee a' m b') 111 | -> Iteratee a m b 112 | -> Iteratee a' m b' 113 | (==<<) = flip (>>==) 114 | 115 | ($$) :: Monad m 116 | => (Step a m b -> Iteratee a' m b') 117 | -> Iteratee a m b 118 | -> Iteratee a' m b' 119 | ($$) = (==<<) 120 | 121 | (>==>) :: Monad m 122 | => Enumerator a m b 123 | -> (Step a m b -> Iteratee a' m b') 124 | -> Step a m b 125 | -> Iteratee a' m b' 126 | (>==>) e1 e2 s = e1 s >>== e2 127 | 128 | (<==<) :: Monad m 129 | => (Step a m b -> Iteratee a' m b') 130 | -> Enumerator a m b 131 | -> Step a m b 132 | -> Iteratee a' m b' 133 | (<==<) = flip (>==>) 134 | 135 | throwError :: (Monad m, Exc.Exception e) => e -> Iteratee a m b 136 | throwError exc = returnI (Error (Exc.toException exc)) 137 | 138 | joinI :: Monad m => Iteratee a m (Step a' m b)-> Iteratee a m b 139 | joinI outer = outer >>= check where 140 | check (Continue k) = k EOF >>== \s -> case s of 141 | Continue _ -> error "joinI: divergent iteratee" 142 | _ -> check s 143 | check (Yield x _) = return x 144 | check (Error e) = throwError e 145 | 146 | iterateeHead :: Monad m => Iteratee a m (Maybe a) 147 | iterateeHead = continue loop 148 | where 149 | loop (Chunks []) = iterateeHead 150 | loop (Chunks (x:xs)) = yield (Just x) (Chunks xs) 151 | loop EOF = yield Nothing EOF 152 | 153 | iterateeLength :: Monad m => Iteratee stream m Int 154 | iterateeLength = continue (loop 0) 155 | where 156 | loop n (Chunks []) = iterateeLength 157 | loop n (Chunks xs) = continue (loop (n + length xs)) 158 | loop n EOF = yield n EOF 159 | 160 | iterateeSum :: Monad m => Iteratee Int m Int 161 | iterateeSum = continue (step 0) 162 | where 163 | step n (Chunks []) = iterateeSum 164 | step n (Chunks xs) = continue (step (n + sum xs)) 165 | step n EOF = yield n EOF 166 | 167 | iterateeDrop :: Monad m => Int -> Iteratee a m () 168 | iterateeDrop n | n <= 0 = return () 169 | iterateeDrop n = continue (loop n) where 170 | loop n' (Chunks xs) = iter where 171 | len = length xs 172 | iter = if len < n' 173 | then iterateeDrop (n' - len) 174 | else yield () (Chunks (drop n' xs)) 175 | loop _ EOF = yield () EOF 176 | 177 | drop1keep1 :: Monad m => Iteratee s m (Maybe s) 178 | drop1keep1 = iterateeDrop 1 >> iterateeHead 179 | 180 | alternates :: Monad m => Iteratee s m [Maybe s] 181 | alternates = replicateM 5 drop1keep1 182 | 183 | checkYield :: Monad m => 184 | ((Stream i -> Iteratee i m a) -> Iteratee o m (Step i m a)) -> 185 | Enumeratee o i m a 186 | checkYield _ y@(Yield x chunk) = return y 187 | checkYield f (Continue k) = f k 188 | 189 | iterateeMap :: Monad m => (o -> i) -> Enumeratee o i m a 190 | iterateeMap f = checkYield $ continue . step where 191 | step k EOF = yield (Continue k) EOF 192 | step k (Chunks []) = continue $ step k 193 | step k chunk = k (fmap f chunk) >>== iterateeMap f 194 | 195 | (=$) :: Monad m => Enumeratee ao ai m b -> Iteratee ai m b -> Iteratee ao m b 196 | enum =$ iter = joinI (enum ==<< iter) 197 | --------------------------------------------------------------------------------