Repository: edwinb/TypeDD-Samples
Branch: master
Commit: a5c08a13e6a6
Files: 164
Total size: 167.0 KB
Directory structure:
gitextract_49twblj_/
├── Chapter1/
│ ├── Exercises/
│ │ └── ex_1_2.idr
│ ├── FCTypes.idr
│ ├── Hello.idr
│ └── HelloHole.idr
├── Chapter10/
│ ├── DLFail.idr
│ ├── DataStore.idr
│ ├── DescribeList.idr
│ ├── DescribeList2.idr
│ ├── Exercises/
│ │ ├── DataStore.idr
│ │ ├── ex_10_1.idr
│ │ ├── ex_10_2.idr
│ │ └── ex_10_3.idr
│ ├── IsSuffix.idr
│ ├── MergeSort.idr
│ ├── MergeSortView.idr
│ ├── Reverse.idr
│ ├── ReverseSnoc.idr
│ ├── Shape.idr
│ ├── Shape_abs.idr
│ ├── SnocList.idr
│ └── TestStore.idr
├── Chapter11/
│ ├── Arith.idr
│ ├── ArithCmd.idr
│ ├── ArithCmdDo.idr
│ ├── ArithTotal.idr
│ ├── Exercises/
│ │ ├── ex_11_1.idr
│ │ ├── ex_11_2.idr
│ │ └── ex_11_3.idr
│ ├── Greet.idr
│ ├── InfIO.idr
│ ├── InfList.idr
│ ├── Label.idr
│ ├── RunIO.idr
│ ├── StreamFail.idr
│ └── Streams.idr
├── Chapter12/
│ ├── ArithState.idr
│ ├── DataStore.idr
│ ├── Exercises/
│ │ ├── ex_12_1.idr
│ │ ├── ex_12_3a.idr
│ │ └── ex_12_3b.idr
│ ├── Record.idr
│ ├── State.idr
│ ├── StateMonad.idr
│ ├── Traverse.idr
│ ├── TreeLabel.idr
│ ├── TreeLabelState.idr
│ └── TreeLabelType.idr
├── Chapter13/
│ ├── Door.idr
│ ├── Exercises/
│ │ ├── ex_13_1.idr
│ │ └── ex_13_2.idr
│ ├── Stack.idr
│ ├── StackIO.idr
│ └── Vending.idr
├── Chapter14/
│ ├── ATM.idr
│ ├── DoorJam.idr
│ ├── Exercises/
│ │ ├── ex_14_2_1.idr
│ │ └── ex_14_2_2.idr
│ └── Hangman.idr
├── Chapter15/
│ ├── AdderChannel.idr
│ ├── ListProc.idr
│ ├── Process.idr
│ ├── ProcessIFace.idr
│ ├── ProcessLib.idr
│ ├── ProcessLoop.idr
│ ├── ProcessState.idr
│ ├── WordCount.idr
│ └── test.txt
├── Chapter2/
│ ├── AveMain.idr
│ ├── Average.idr
│ ├── Double.idr
│ ├── Exercises/
│ │ ├── ex_2.ibc
│ │ ├── ex_2.idr
│ │ ├── ex_2_counts.ibc
│ │ ├── ex_2_counts.idr
│ │ ├── ex_2_palindrome.ibc
│ │ └── ex_2_palindrome.idr
│ ├── Generic.idr
│ ├── HOF.idr
│ ├── Let_Where.idr
│ ├── Partial.idr
│ └── Reverse.idr
├── Chapter3/
│ ├── Exercises/
│ │ ├── ex_3_2.ibc
│ │ ├── ex_3_2.idr
│ │ ├── ex_3_3.ibc
│ │ └── ex_3_3.idr
│ ├── IsEven.idr
│ ├── Matrix.idr
│ ├── VecSort.idr
│ ├── Vectors.idr
│ ├── WordLength.idr
│ ├── WordLength_vec.idr
│ └── XOR.idr
├── Chapter4/
│ ├── BSTree.idr
│ ├── DataStore.idr
│ ├── Direction.idr
│ ├── Exercises/
│ │ ├── ex_4_1.idr
│ │ ├── ex_4_2.idr
│ │ ├── ex_4_2_1.idr
│ │ ├── ex_4_2_2.idr
│ │ ├── ex_4_2_3.idr
│ │ ├── ex_4_2_5.idr
│ │ └── ex_4_3.idr
│ ├── Generic.idr
│ ├── Picture.idr
│ ├── Shape.idr
│ ├── SumInputs.idr
│ ├── Tree.idr
│ ├── TryIndex.idr
│ ├── Vect.idr
│ └── Vehicle.idr
├── Chapter5/
│ ├── DepPairs.idr
│ ├── Do.idr
│ ├── Exercises/
│ │ ├── ex_5_1.idr
│ │ ├── ex_5_2_1.idr
│ │ ├── ex_5_2_3.idr
│ │ ├── ex_5_2_4.idr
│ │ └── ex_5_3.idr
│ ├── Hello.idr
│ ├── Loops.idr
│ ├── PrintLength.idr
│ ├── ReadNum.idr
│ └── ReadVect.idr
├── Chapter6/
│ ├── Adder.idr
│ ├── DataStore.idr
│ ├── DataStoreHoles.idr
│ ├── Exercises/
│ │ ├── ex_6_2_1.idr
│ │ ├── ex_6_2_2.idr
│ │ ├── ex_6_2_3.idr
│ │ ├── ex_6_3_1.idr
│ │ ├── ex_6_3_2.idr
│ │ └── ex_6_3_3.idr
│ ├── Maybe.idr
│ ├── Printf.idr
│ ├── TypeFuns.idr
│ └── TypeSynonyms.idr
├── Chapter7/
│ ├── Album.idr
│ ├── Eq.idr
│ ├── Exercises/
│ │ ├── ex_7_1.idr
│ │ ├── ex_7_2.idr
│ │ ├── ex_7_3_1.idr
│ │ └── ex_7_3_2.idr
│ ├── Expr.idr
│ ├── Fold.idr
│ └── Tree.idr
├── Chapter8/
│ ├── AppendVec.idr
│ ├── CheckEqDec.idr
│ ├── CheckEqMaybe.idr
│ ├── EqNat.idr
│ ├── ExactLength.idr
│ ├── ExactLengthDec.idr
│ ├── Exercises/
│ │ ├── ex_8_1.idr
│ │ ├── ex_8_2.idr
│ │ └── ex_8_3.idr
│ ├── ReverseVec.idr
│ ├── TCVects.idr
│ └── Void.idr
├── Chapter9/
│ ├── Elem.idr
│ ├── ElemBool.idr
│ ├── ElemType.idr
│ ├── Exercises/
│ │ └── ex_9_1.idr
│ ├── Hangman.idr
│ └── RemoveElem.idr
├── LICENSE
└── README.md
================================================
FILE CONTENTS
================================================
================================================
FILE: Chapter1/Exercises/ex_1_2.idr
================================================
{-
1. Anything where the list is the same length as the input. We don't know
the types of elements contained in the list, however, so we can't look at them.
Some possibilities (there are many others!):
- sorting the list
- reversing the list
- returning the input unchanged
2. Anything where the output list is twice as long as the input.
Some possibilities:
- Duplicating each element
- Returning the list appended to itself
3. Anything where the output list is one item shorter than the input, which
must itself be non-empty. Some possibilities:
- Returning all but the first element
- Returning all but the last element
4. The bounded number is likely to refer to a position in the list, so this
could be a function to return the element at that position.
-}
================================================
FILE: Chapter1/FCTypes.idr
================================================
StringOrInt : Bool -> Type
StringOrInt x = case x of
True => Int
False => String
getStringOrInt : (x : Bool) -> StringOrInt x
getStringOrInt x = case x of
True => 94
False => "Ninety four"
valToString : (x : Bool) -> StringOrInt x -> String
valToString x val = case x of
True => cast val
False => val
================================================
FILE: Chapter1/Hello.idr
================================================
module Main
main : IO ()
main = putStrLn "Hello, Idris world!"
================================================
FILE: Chapter1/HelloHole.idr
================================================
module Main
main : IO ()
main = putStrLn ?greeting
================================================
FILE: Chapter10/DLFail.idr
================================================
describe_list_end : List Int -> String
describe_list_end [] = "Empty"
describe_list_end (xs ++ [x]) = "Non-empty, initial portion = " ++ show xs
================================================
FILE: Chapter10/DataStore.idr
================================================
module DataStore
import Data.Vect
infixr 5 .+.
public export
data Schema = SString | SInt | (.+.) Schema Schema
public export
SchemaType : Schema -> Type
SchemaType SString = String
SchemaType SInt = Int
SchemaType (x .+. y) = (SchemaType x, SchemaType y)
export
record DataStore (schema : Schema) where
constructor MkData
size : Nat
items : Vect size (SchemaType schema)
export
empty : DataStore schema
empty = MkData 0 []
export
addToStore : (entry : SchemaType schema) ->
(store : DataStore schema) ->
DataStore schema
addToStore entry (MkData _ items)
= MkData _ (entry :: items)
public export
data StoreView : DataStore schema -> Type where
SNil : StoreView empty
SAdd : (rec : StoreView store) -> StoreView (addToStore entry store)
storeViewHelp : (items : Vect size (SchemaType schema)) ->
StoreView (MkData size items)
storeViewHelp [] = SNil
storeViewHelp (entry :: xs) = SAdd (storeViewHelp xs)
export
storeView : (store : DataStore schema) -> StoreView store
storeView (MkData size items)
= storeViewHelp items
================================================
FILE: Chapter10/DescribeList.idr
================================================
data ListLast : List a -> Type where
Empty : ListLast []
NonEmpty : (xs : List a) -> (x : a) -> ListLast (xs ++ [x])
listLast : (xs : List a) -> ListLast xs
listLast [] = Empty
listLast (x :: xs) = case listLast xs of
Empty => NonEmpty [] x
NonEmpty xs y => NonEmpty (x :: xs) y
describeHelper : (input : List Int) -> ListLast input -> String
describeHelper [] Empty = "Empty"
describeHelper (xs ++ [x]) (NonEmpty xs x)
= "Non-empty, initial portion = " ++ show xs
describeListEnd : List Int -> String
describeListEnd xs = describeHelper xs (listLast xs)
================================================
FILE: Chapter10/DescribeList2.idr
================================================
data ListLast : List a -> Type where
Empty : ListLast []
NonEmpty : (xs : List a) -> (x : a) -> ListLast (xs ++ [x])
listLast : (xs : List a) -> ListLast xs
listLast [] = Empty
listLast (x :: xs) = case listLast xs of
Empty => NonEmpty [] x
NonEmpty xs y => NonEmpty (x :: xs) y
describe_list_end : List Int -> String
describe_list_end input with (listLast input)
describe_list_end [] | Empty = ?describe_list_end_rhs_1
describe_list_end (xs ++ [x]) | (NonEmpty xs x) = ?describe_list_end_rhs_2
================================================
FILE: Chapter10/Exercises/DataStore.idr
================================================
module DataStore
import Data.Vect
infixr 5 .+.
public export
data Schema = SString | SInt | (.+.) Schema Schema
public export
SchemaType : Schema -> Type
SchemaType SString = String
SchemaType SInt = Int
SchemaType (x .+. y) = (SchemaType x, SchemaType y)
export
record DataStore (schema : Schema) where
constructor MkData
size : Nat
items : Vect size (SchemaType schema)
export
empty : DataStore schema
empty = MkData 0 []
export
addToStore : (entry : SchemaType schema) ->
(store : DataStore schema) ->
DataStore schema
addToStore entry (MkData _ items)
= MkData _ (entry :: items)
public export
data StoreView : DataStore schema -> Type where
SNil : StoreView empty
SAdd : (rec : StoreView store) -> StoreView (addToStore entry store)
storeViewHelp : (items : Vect size (SchemaType schema)) ->
StoreView (MkData size items)
storeViewHelp [] = SNil
storeViewHelp (entry :: xs) = SAdd (storeViewHelp xs)
export
storeView : (store : DataStore schema) -> StoreView store
storeView (MkData size items)
= storeViewHelp items
================================================
FILE: Chapter10/Exercises/ex_10_1.idr
================================================
{- 1 -}
data TakeN : List a -> Type where
Fewer : TakeN xs
Exact : (n_xs : List a) -> TakeN (n_xs ++ rest)
takeN : (n : Nat) -> (xs : List a) -> TakeN xs
takeN Z xs = Exact []
takeN (S k) [] = Fewer
takeN (S k) (x :: xs) with (takeN k xs)
takeN (S k) (x :: xs) | Fewer = Fewer
takeN (S k) (x :: (n_xs ++ rest)) | Exact _ = Exact (x :: n_xs)
groupByN : (n : Nat) -> (xs : List a) -> List (List a)
groupByN n xs with (takeN n xs)
groupByN n xs | Fewer = [xs]
groupByN n (n_xs ++ rest) | (Exact n_xs) = n_xs :: groupByN n rest
{- 2 -}
halves : List a -> (List a, List a)
halves input with (takeN (length input `div` 2) input)
halves input | Fewer = (input, [])
halves (n_xs ++ rest) | (Exact n_xs) = (n_xs, rest)
================================================
FILE: Chapter10/Exercises/ex_10_2.idr
================================================
import Data.Vect
import Data.List.Views
import Data.Vect.Views
import Data.Nat.Views
{- 1 -}
total
equalSuffix : Eq a => List a -> List a -> List a
equalSuffix input1 input2 with (snocList input1)
equalSuffix [] input2 | Empty = []
equalSuffix (xs ++ [x]) input2 | (Snoc xsrec) with (snocList input2)
equalSuffix (xs ++ [x]) [] | (Snoc xsrec) | Empty = []
equalSuffix (xs ++ [x]) (ys ++ [y]) | (Snoc xsrec) | (Snoc ysrec)
= if x == y
then equalSuffix xs ys | xsrec | ysrec ++ [y]
else []
{- 2 -}
total
mergeSort : Ord a => Vect n a -> Vect n a
mergeSort xs with (splitRec xs)
mergeSort [] | SplitRecNil = []
mergeSort [x] | SplitRecOne = [x]
mergeSort (ys ++ zs) | (SplitRecPair lrec rrec)
= merge (mergeSort ys | lrec) (mergeSort zs | rrec)
{- 3 -}
total
toBinary : Nat -> String
toBinary k with (halfRec k)
toBinary Z | HalfRecZ = ""
toBinary (n + n) | (HalfRecEven rec) = toBinary n | rec ++ "0"
toBinary (S (n + n)) | (HalfRecOdd rec) = toBinary n | rec ++ "1"
{- 4 -}
palindrome : Eq a => List a -> Bool
palindrome input with (vList input)
palindrome [] | VNil = True
palindrome [x] | VOne = True
palindrome (x :: (xs ++ [y])) | (VCons rec)
= x == y && palindrome xs
================================================
FILE: Chapter10/Exercises/ex_10_3.idr
================================================
import DataStore
import Data.Vect
{- 1 -}
testStore : DataStore (SString .+. SInt)
testStore = addToStore ("First", 1) $
addToStore ("Second", 2) $
empty
getValues : DataStore (SString .+. val_schema) ->
List (SchemaType val_schema)
getValues input with (storeView input)
getValues empty | SNil = []
getValues (addToStore (key, value) store) | (SAdd rec)
= value :: getValues store | rec
{- 2 -}
export
data Shape = Triangle Double Double
| Rectangle Double Double
| Circle Double
export
triangle : Double -> Double -> Shape
triangle = Triangle
export
rectangle : Double -> Double -> Shape
rectangle = Rectangle
export
circle : Double -> Shape
circle = Circle
data ShapeView : Shape -> Type where
STriangle : ShapeView (triangle base height)
SRectangle : ShapeView (rectangle width height)
SCircle : ShapeView (circle radius)
shapeView : (s : Shape) -> ShapeView s
shapeView (Triangle x y) = STriangle
shapeView (Rectangle x y) = SRectangle
shapeView (Circle x) = SCircle
area : Shape -> Double
area s with (shapeView s)
area (triangle base height) | STriangle = 0.5 * base * height
area (rectangle width height) | SRectangle = width * height
area (circle radius) | SCircle = pi * radius * radius
================================================
FILE: Chapter10/IsSuffix.idr
================================================
import Data.List.Views
total
isSuffix : Eq a => List a -> List a -> Bool
isSuffix input1 input2 with (snocList input1)
isSuffix [] input2 | Empty = False
isSuffix (xs ++ [x]) input2 | (Snoc xsrec) with (snocList input2)
isSuffix (xs ++ [x]) [] | (Snoc xsrec) | Empty = False
isSuffix (xs ++ [x]) (ys ++ [y]) | (Snoc xsrec) | (Snoc ysrec)
= if x == y then isSuffix xs ys | xsrec | ysrec
else False
================================================
FILE: Chapter10/MergeSort.idr
================================================
import Debug.Trace
data SplitList : List a -> Type where
SplitNil : SplitList []
SplitOne : SplitList [x]
SplitPair : (lefts : List a) -> (rights : List a) ->
SplitList (lefts ++ rights)
total
splitList : (xs : List a) -> SplitList xs
splitList xs = splitListHelp xs xs
where
splitListHelp : (counter : List a) -> (xs : List a) -> SplitList xs
splitListHelp _ [] = SplitNil
splitListHelp _ [x] = SplitOne
splitListHelp (_ :: _ :: ys) (x :: xs)
= case splitListHelp ys xs of
SplitNil => SplitOne
SplitOne {x=y} => SplitPair [x] [y]
SplitPair lefts rights => SplitPair (x :: lefts) rights
splitListHelp _ xs = SplitPair [] xs
mergeSort : Ord a => List a -> List a
mergeSort input with (splitList input)
mergeSort [] | SplitNil = []
mergeSort [x] | SplitOne = [x]
mergeSort (lefts ++ rights) | (SplitPair lefts rights)
= merge (mergeSort lefts) (mergeSort rights)
================================================
FILE: Chapter10/MergeSortView.idr
================================================
import Data.List.Views
mergeSort : Ord a => List a -> List a
mergeSort input with (splitRec input)
mergeSort [] | SplitRecNil = []
mergeSort [x] | SplitRecOne = [x]
mergeSort (lefts ++ rights) | (SplitRecPair lrec rrec)
= merge (mergeSort lefts | lrec)
(mergeSort rights | rrec)
================================================
FILE: Chapter10/Reverse.idr
================================================
data ListLast : List a -> Type where
Empty : ListLast []
NonEmpty : (xs : List a) -> (x : a) -> ListLast (xs ++ [x])
listLast : (xs : List a) -> ListLast xs
listLast [] = Empty
listLast (x :: xs) = case listLast xs of
Empty => NonEmpty [] x
NonEmpty xs y => NonEmpty (x :: xs) y
myReverse : List a -> List a
myReverse input with (listLast input)
myReverse [] | Empty = []
myReverse (xs ++ [x]) | (NonEmpty xs x) = x :: myReverse xs
================================================
FILE: Chapter10/ReverseSnoc.idr
================================================
data SnocList ty = Empty | Snoc (SnocList ty) ty
reverseSnoc : SnocList ty -> List ty
reverseSnoc Empty = []
reverseSnoc (Snoc xs x) = x :: reverseSnoc xs
================================================
FILE: Chapter10/Shape.idr
================================================
module Shape
public export
data Shape = Triangle Double Double
| Rectangle Double Double
| Circle Double
private
rectangle_area : Double -> Double -> Double
rectangle_area width height = width * height
export
area : Shape -> Double
area (Triangle base height) = 0.5 * rectangle_area base height
area (Rectangle length height) = rectangle_area length height
area (Circle radius) = pi * radius * radius
================================================
FILE: Chapter10/Shape_abs.idr
================================================
module Shape_abs
export
data Shape = Triangle Double Double
| Rectangle Double Double
| Circle Double
export
triangle : Double -> Double -> Shape
triangle = Triangle
export
rectangle : Double -> Double -> Shape
rectangle = Rectangle
export
circle : Double -> Shape
circle = Circle
private
rectangle_area : Double -> Double -> Double
rectangle_area width height = width * height
export
area : Shape -> Double
area (Triangle base height) = 0.5 * rectangle_area base height
area (Rectangle length height) = rectangle_area length height
area (Circle radius) = pi * radius * radius
================================================
FILE: Chapter10/SnocList.idr
================================================
data SnocList : List a -> Type where
Empty : SnocList []
Snoc : (rec : SnocList xs) -> SnocList (xs ++ [x])
snocListHelp : (snoc : SnocList input) -> (rest : List a) -> SnocList (input ++ rest)
snocListHelp {input} snoc [] = rewrite appendNilRightNeutral input in snoc
snocListHelp {input} snoc (x :: xs)
= rewrite appendAssociative input [x] xs in snocListHelp (Snoc snoc) xs
snocList : (xs : List a) -> SnocList xs
snocList xs = snocListHelp Empty xs
my_reverse_help : (input : List a) -> SnocList input -> List a
my_reverse_help [] Empty = []
my_reverse_help (xs ++ [x]) (Snoc rec) = x :: my_reverse_help xs rec
my_reverse1 : List a -> List a
my_reverse1 input = my_reverse_help input (snocList input)
my_reverse : List a -> List a
my_reverse input with (snocList input)
my_reverse [] | Empty = []
my_reverse (xs ++ [x]) | (Snoc rec) = x :: my_reverse xs | rec
================================================
FILE: Chapter10/TestStore.idr
================================================
import DataStore
testStore : DataStore (SString .+. SString .+. SInt)
testStore = addToStore ("Mercury", "Mariner 10", 1974) $
addToStore ("Venus", "Venera", 1961) $
addToStore ("Uranus", "Voyager 2", 1986) $
addToStore ("Pluto", "New Horizons", 2015) $
empty
listItems : DataStore schema -> List (SchemaType schema)
listItems input with (storeView input)
listItems empty | SNil = []
listItems (addToStore entry store) | (SAdd rec)
= entry :: listItems store | rec
filterKeys : (test : SchemaType val_schema -> Bool) ->
DataStore (SString .+. val_schema) -> List String
filterKeys test input with (storeView input)
filterKeys test input | SNil = []
filterKeys test (addToStore (key, value) store) | (SAdd rec)
= if test value
then key :: filterKeys test store | rec
else filterKeys test store | rec
================================================
FILE: Chapter11/Arith.idr
================================================
import Data.Primitives.Views
import System
quiz : Stream Int -> (score : Nat) -> IO ()
quiz (num1 :: num2 :: nums) score
= do putStrLn ("Score so far: " ++ show score)
putStr (show num1 ++ " * " ++ show num2 ++ "? ")
answer <- getLine
if cast answer == num1 * num2
then do putStrLn "Correct!"
quiz nums (score + 1)
else do putStrLn ("Wrong, the answer is " ++ show (num1 * num2))
quiz nums score
randoms : Int -> Stream Int
randoms seed = let seed' = 1664525 * seed + 1013904223 in
(seed' `shiftR` 2) :: randoms seed'
arithInputs : Int -> Stream Int
arithInputs seed = map bound (randoms seed)
where
bound : Int -> Int
bound x with (divides x 12)
bound ((12 * div) + rem) | (DivBy prf) = rem + 1
main : IO ()
main = do seed <- time
quiz (arithInputs (fromInteger seed)) 0
================================================
FILE: Chapter11/ArithCmd.idr
================================================
import Data.Primitives.Views
import System
%default total
data Command : Type -> Type where
PutStr : String -> Command ()
GetLine : Command String
data ConsoleIO : Type -> Type where
Quit : a -> ConsoleIO a
Do : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b
(>>=) : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b
(>>=) = Do
data Fuel = Dry | More (Lazy Fuel)
runCommand : Command a -> IO a
runCommand (PutStr x) = putStr x
runCommand GetLine = getLine
run : Fuel -> ConsoleIO a -> IO (Maybe a)
run fuel (Quit val) = do pure (Just val)
run (More fuel) (Do c f) = do res <- runCommand c
run fuel (f res)
run Dry p = pure Nothing
randoms : Int -> Stream Int
randoms seed = let seed' = 1664525 * seed + 1013904223 in
(seed' `shiftR` 2) :: randoms seed'
arithInputs : Int -> Stream Int
arithInputs seed = map bound (randoms seed)
where
bound : Int -> Int
bound x with (divides x 12)
bound ((12 * div) + rem) | (DivBy prf) = abs rem + 1
mutual
correct : Stream Int -> (score : Nat) -> ConsoleIO Nat
correct nums score
= do PutStr "Correct!\n"
quiz nums (score + 1)
wrong : Stream Int -> Int -> (score : Nat) -> ConsoleIO Nat
wrong nums ans score
= do PutStr ("Wrong, the answer is " ++ show ans ++ "\n")
quiz nums score
quiz : Stream Int -> (score : Nat) -> ConsoleIO Nat
quiz (num1 :: num2 :: nums) score
= do PutStr ("Score so far: " ++ show score ++ "\n")
PutStr (show num1 ++ " * " ++ show num2 ++ "? ")
answer <- GetLine
if toLower answer == "quit" then Quit score else
if (cast answer == num1 * num2)
then correct nums score
else wrong nums (num1 * num2) score
partial
forever : Fuel
forever = More forever
partial
main : IO ()
main = do seed <- time
Just score <- run forever (quiz (arithInputs (fromInteger seed)) 0)
| Nothing => putStrLn "Ran out of fuel"
putStrLn ("Final score: " ++ show score)
================================================
FILE: Chapter11/ArithCmdDo.idr
================================================
import Data.Primitives.Views
import System
%default total
data Command : Type -> Type where
PutStr : String -> Command ()
GetLine : Command String
Pure : ty -> Command ty
Bind : Command a -> (a -> Command b) -> Command b
data ConsoleIO : Type -> Type where
Quit : a -> ConsoleIO a
Do : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b
namespace CommandDo
(>>=) : Command a -> (a -> Command b) -> Command b
(>>=) = Bind
namespace ConsoleDo
(>>=) : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b
(>>=) = Do
data Fuel = Dry | More (Lazy Fuel)
runCommand : Command a -> IO a
runCommand (PutStr x) = putStr x
runCommand GetLine = getLine
runCommand (Pure val) = pure val
runCommand (Bind c f) = do res <- runCommand c
runCommand (f res)
run : Fuel -> ConsoleIO a -> IO (Maybe a)
run fuel (Quit val) = do pure (Just val)
run (More fuel) (Do c f) = do res <- runCommand c
run fuel (f res)
run Dry p = pure Nothing
randoms : Int -> Stream Int
randoms seed = let seed' = 1664525 * seed + 1013904223 in
(seed' `shiftR` 2) :: randoms seed'
arithInputs : Int -> Stream Int
arithInputs seed = map bound (randoms seed)
where
bound : Int -> Int
bound x with (divides x 12)
bound ((12 * div) + rem) | (DivBy prf) = abs rem + 1
mutual
correct : Stream Int -> (score : Nat) -> ConsoleIO Nat
correct nums score
= do PutStr "Correct!\n"
quiz nums (score + 1)
wrong : Stream Int -> Int -> (score : Nat) -> ConsoleIO Nat
wrong nums ans score
= do PutStr ("Wrong, the answer is " ++ show ans ++ "\n")
quiz nums score
data Input = Answer Int
| QuitCmd
readInput : (prompt : String) -> Command Input
readInput prompt
= do PutStr prompt
answer <- GetLine
if toLower answer == "quit"
then Pure QuitCmd
else Pure (Answer (cast answer))
quiz : Stream Int -> (score : Nat) -> ConsoleIO Nat
quiz (num1 :: num2 :: nums) score
= do PutStr ("Score so far: " ++ show score ++ "\n")
input <- readInput (show num1 ++ " * " ++ show num2 ++ "? ")
case input of
Answer answer => if answer == num1 * num2
then correct nums score
else wrong nums (num1 * num2) score
QuitCmd => Quit score
partial
forever : Fuel
forever = More forever
partial
main : IO ()
main = do seed <- time
Just score <- run forever (quiz (arithInputs (fromInteger seed)) 0)
| Nothing => putStrLn "Ran out of fuel"
putStrLn ("Final score: " ++ show score)
================================================
FILE: Chapter11/ArithTotal.idr
================================================
import Data.Primitives.Views
import System
%default total
data InfIO : Type where
Do : IO a -> (a -> Inf InfIO) -> InfIO
(>>=) : IO a -> (a -> Inf InfIO) -> InfIO
(>>=) = Do
data Fuel = Dry | More (Lazy Fuel)
run : Fuel -> InfIO -> IO ()
run (More fuel) (Do c f) = do res <- c
run fuel (f res)
run Dry p = putStrLn "Out of fuel"
randoms : Int -> Stream Int
randoms seed = let seed' = 1664525 * seed + 1013904223 in
(seed' `shiftR` 2) :: randoms seed'
arithInputs : Int -> Stream Int
arithInputs seed = map bound (randoms seed)
where
bound : Int -> Int
bound x with (divides x 12)
bound ((12 * div) + rem) | (DivBy prf) = abs rem + 1
quiz : Stream Int -> (score : Nat) -> InfIO
quiz (num1 :: num2 :: nums) score
= do putStrLn ("Score so far: " ++ show score)
putStr (show num1 ++ " * " ++ show num2 ++ "? ")
answer <- getLine
if (cast answer == num1 * num2)
then do putStrLn "Correct!"
quiz nums (score + 1)
else do putStrLn ("Wrong, the answer is " ++ show (num1 * num2))
quiz nums score
partial
forever : Fuel
forever = More forever
partial
main : IO ()
main = do seed <- time
run forever (quiz (arithInputs (fromInteger seed)) 0)
================================================
FILE: Chapter11/Exercises/ex_11_1.idr
================================================
import Data.Primitives.Views
{- 1 -}
every_other : Stream a -> Stream a
every_other (x :: y :: xs) = y :: every_other xs
{- 2 -}
data InfList : Type -> Type where
(::) : (value : elem) -> Inf (InfList elem) -> InfList elem
%name InfList xs, ys, zs
countFrom : Integer -> InfList Integer
countFrom x = x :: Delay (countFrom (x + 1))
getPrefix : (count : Nat) -> InfList a -> List a
getPrefix Z xs = []
getPrefix (S k) (value :: xs) = value :: getPrefix k xs
Functor InfList where
map func (value :: xs) = func value :: map func xs
{- 3 -}
randoms : Int -> Stream Int
randoms seed = let seed' = 1664525 * seed + 1013904223 in
(seed' `shiftR` 2) :: randoms seed'
data Face = Heads | Tails
total
getFace : Int -> Face
getFace x with (divides x 2)
getFace ((2 * div) + rem) | (DivBy prf)
= case rem of
0 => Heads
_ => Tails
coinFlips : Nat -> Stream Int -> List Face
coinFlips k rnds = map getFace (take k rnds)
{- 4 -}
square_root_approx : (number : Double) -> (approx : Double) -> Stream Double
square_root_approx number approx
= let next = (approx + (number / approx)) / 2 in
approx :: square_root_approx number next
{- 5 -}
square_root_bound : (max : Nat) -> (number : Double) -> (bound : Double) ->
(approxs : Stream Double) -> Double
square_root_bound Z number bound (x :: xs) = x
square_root_bound (S k) number bound (x :: xs) =
if (abs (x * x - number) < bound)
then x
else square_root_bound k number bound xs
square_root : (number : Double) -> Double
square_root number = square_root_bound 100 number 0.00000000001
(square_root_approx number number)
================================================
FILE: Chapter11/Exercises/ex_11_2.idr
================================================
{- Preamble, solution below -}
import Data.Primitives.Views
import System
%default total
data InfIO : Type where
Do : IO a -> (a -> Inf InfIO) -> InfIO
(>>=) : IO a -> (a -> Inf InfIO) -> InfIO
(>>=) = Do
data Fuel = Dry | More (Lazy Fuel)
run : Fuel -> InfIO -> IO ()
run (More fuel) (Do c f) = do res <- c
run fuel (f res)
run Dry p = putStrLn "Out of fuel"
randoms : Int -> Stream Int
randoms seed = let seed' = 1664525 * seed + 1013904223 in
(seed' `shiftR` 2) :: randoms seed'
arithInputs : Int -> Stream Int
arithInputs seed = map bound (randoms seed)
where
bound : Int -> Int
bound x with (divides x 12)
bound ((12 * div) + rem) | (DivBy prf) = abs rem + 1
partial
forever : Fuel
forever = More forever
{- Solution -}
totalREPL : (prompt : String) -> (action : String -> String) -> InfIO
totalREPL prompt action =
do putStr prompt
inp <- getLine
putStr (action inp)
totalREPL prompt action
================================================
FILE: Chapter11/Exercises/ex_11_3.idr
================================================
import Data.Primitives.Views
import System
%default total
data Command : Type -> Type where
PutStr : String -> Command ()
GetLine : Command String
data ConsoleIO : Type -> Type where
Quit : a -> ConsoleIO a
Do : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b
(>>=) : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b
(>>=) = Do
data Fuel = Dry | More (Lazy Fuel)
runCommand : Command a -> IO a
runCommand (PutStr x) = putStr x
runCommand GetLine = getLine
run : Fuel -> ConsoleIO a -> IO (Maybe a)
run fuel (Quit val) = do pure (Just val)
run (More fuel) (Do c f) = do res <- runCommand c
run fuel (f res)
run Dry p = pure Nothing
randoms : Int -> Stream Int
randoms seed = let seed' = 1664525 * seed + 1013904223 in
(seed' `shiftR` 2) :: randoms seed'
arithInputs : Int -> Stream Int
arithInputs seed = map bound (randoms seed)
where
bound : Int -> Int
bound x with (divides x 12)
bound ((12 * div) + rem) | (DivBy prf) = abs rem + 1
quiz : Stream Int -> (score : Nat) -> (questions : Nat) -> ConsoleIO (Nat, Nat)
quiz (num1 :: num2 :: nums) score questions
= do PutStr ("Score so far: " ++ show score ++ " / " ++ show questions ++ "\n")
PutStr (show num1 ++ " * " ++ show num2 ++ "? ")
answer <- GetLine
if toLower answer == "quit" then Quit (score, questions) else
if (cast answer == num1 * num2)
then do PutStr "Correct!\n"
quiz nums (score + 1) (questions + 1)
else do PutStr ("Wrong, the answer is " ++ show (num1 * num2) ++ "\n")
quiz nums score (questions + 1)
partial
forever : Fuel
forever = More forever
partial
main : IO ()
main = do seed <- time
Just (score, qs) <- run forever (quiz (arithInputs (fromInteger seed)) 0 0)
| Nothing => putStrLn "Ran out of fuel"
putStrLn ("Final score: " ++ show score ++ " / " ++ show qs)
================================================
FILE: Chapter11/Greet.idr
================================================
%default total
data InfIO : Type where
Do : IO a -> (a -> Inf InfIO) -> InfIO
(>>=) : IO a -> (a -> Inf InfIO) -> InfIO
(>>=) = Do
greet : InfIO
greet = do putStr "Enter your name: "
name <- getLine
putStrLn ("Hello " ++ name)
greet
================================================
FILE: Chapter11/InfIO.idr
================================================
%default total
data InfIO : Type where
Do : IO a -> (a -> Inf InfIO) -> InfIO
(>>=) : IO a -> (a -> Inf InfIO) -> InfIO
(>>=) = Do
loopPrint : String -> InfIO
loopPrint msg = do putStrLn msg
loopPrint msg
data Fuel = Dry | More (Lazy Fuel)
tank : Nat -> Fuel
tank Z = Dry
tank (S k) = More (tank k)
partial
runPartial : InfIO -> IO ()
runPartial (Do action f) = do res <- action
runPartial (f res)
run : Fuel -> InfIO -> IO ()
run (More fuel) (Do c f) = do res <- c
run fuel (f res)
run Dry p = putStrLn "Out of fuel"
partial
forever : Fuel
forever = More forever
partial
main : IO ()
main = run (tank 10) (loopPrint "vroom")
================================================
FILE: Chapter11/InfList.idr
================================================
data InfList : Type -> Type where
(::) : (value : elem) -> Inf (InfList elem) -> InfList elem
%name InfList xs, ys, zs
countFrom : Integer -> InfList Integer
countFrom x = x :: Delay (countFrom (x + 1))
getPrefix : (count : Nat) -> InfList a -> List a
getPrefix Z xs = []
getPrefix (S k) (value :: xs) = value :: getPrefix k xs
labelWith : InfList Integer -> List a -> List (Integer, a)
labelWith (lbl :: lbls) [] = []
labelWith (lbl :: lbls) (val :: vals) = (lbl, val) :: labelWith lbls vals
label : List a -> List (Integer, a)
label = labelWith (countFrom 0)
================================================
FILE: Chapter11/Label.idr
================================================
labelFrom : Integer -> List a -> List (Integer, a)
labelFrom lbl [] = []
labelFrom lbl (val :: vals) = (lbl, val) :: labelFrom (lbl + 1) vals
label : List a -> List (Integer, a)
label = labelFrom 0
================================================
FILE: Chapter11/RunIO.idr
================================================
%default total
data RunIO : Type -> Type where
Quit : a -> RunIO a
Do : IO a -> (a -> Inf (RunIO b)) -> RunIO b
(>>=) : IO a -> (a -> Inf (RunIO b)) -> RunIO b
(>>=) = Do
greet : RunIO ()
greet = do putStr "Enter your name: "
name <- getLine
if name == ""
then do putStrLn "Bye bye!"
Quit ()
else do putStrLn ("Hello " ++ name)
greet
data Fuel = Dry | More (Lazy Fuel)
run : Fuel -> RunIO a -> IO (Maybe a)
run fuel (Quit val) = do pure (Just val)
run (More fuel) (Do c f) = do res <- c
run fuel (f res)
run Dry p = pure Nothing
partial
forever : Fuel
forever = More forever
partial
main : IO ()
main = do run forever greet
pure ()
================================================
FILE: Chapter11/StreamFail.idr
================================================
countFrom : Integer -> List Integer
countFrom n = n :: countFrom (n + 1)
labelWith : List Integer -> List a -> List (Integer, a)
labelWith lbls [] = []
labelWith (lbl :: lbls) (val :: vals) = (lbl, val) :: labelWith lbls vals
================================================
FILE: Chapter11/Streams.idr
================================================
labelWith : Stream labelType -> List a -> List (labelType, a)
labelWith lbls [] = []
labelWith (lbl :: lbls) (val :: vals) = (lbl, val) :: labelWith lbls vals
label : List a -> List (Integer, a)
label vals = labelWith (iterate (+1) 0) vals
================================================
FILE: Chapter12/ArithState.idr
================================================
import Data.Primitives.Views
import System
%default total
record Score where
constructor MkScore
correct : Nat
attempted : Nat
record GameState where
constructor MkGameState
score : Score
difficulty : Int
Show GameState where
show st = show (correct (score st)) ++ "/" ++
show (attempted (score st)) ++ "\n" ++
"Difficulty: " ++ show (difficulty st)
initState : GameState
initState = MkGameState (MkScore 0 0) 12
addWrong : GameState -> GameState
addWrong = record { score->attempted $= (+1) }
addCorrect : GameState -> GameState
addCorrect = record { score->correct $= (+1),
score->attempted $= (+1) }
setDifficulty : Int -> GameState -> GameState
setDifficulty newDiff state = record { difficulty = newDiff } state
data Command : Type -> Type where
PutStr : String -> Command ()
GetLine : Command String
GetRandom : Command Int
GetGameState : Command GameState
PutGameState : GameState -> Command ()
Pure : ty -> Command ty
Bind : Command a -> (a -> Command b) -> Command b
data ConsoleIO : Type -> Type where
Quit : a -> ConsoleIO a
Do : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b
namespace ConsoleDo
(>>=) : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b
(>>=) = Do
namespace CommandDo
(>>=) : Command a -> (a -> Command b) -> Command b
(>>=) = Bind
randoms : Int -> Stream Int
randoms seed = let seed' = 1664525 * seed + 1013904223 in
(seed' `shiftR` 2) :: randoms seed'
runCommand : Stream Int -> GameState -> Command a ->
IO (a, Stream Int, GameState)
runCommand rnds state (PutStr x) = do putStr x
pure ((), rnds, state)
runCommand rnds state GetLine = do str <- getLine
pure (str, rnds, state)
runCommand (val :: rnds) state GetRandom
= pure (getRandom val (difficulty state), rnds, state)
where
getRandom : Int -> Int -> Int
getRandom val max with (divides val max)
getRandom val 0 | DivByZero = 1
getRandom ((max * div) + rem) max | (DivBy prf) = abs rem + 1
runCommand rnds state GetGameState
= pure (state, rnds, state)
runCommand rnds state (PutGameState newState)
= pure ((), rnds, newState)
runCommand rnds state (Pure val)
= pure (val, rnds, state)
runCommand rnds state (Bind c f)
= do (res, newRnds, newState) <- runCommand rnds state c
runCommand newRnds newState (f res)
data Fuel = Dry | More (Lazy Fuel)
partial
forever : Fuel
forever = More forever
run : Fuel -> Stream Int -> GameState -> ConsoleIO a ->
IO (Maybe a, Stream Int, GameState)
run fuel rnds state (Quit val) = do pure (Just val, rnds, state)
run (More fuel) rnds state (Do c f)
= do (res, newRnds, newState) <- runCommand rnds state c
run fuel newRnds newState (f res)
run Dry rnds state p = pure (Nothing, rnds, state)
mutual
correct : ConsoleIO GameState
correct = do PutStr "Correct!\n"
st <- GetGameState
PutGameState (addCorrect st)
quiz
wrong : Int -> ConsoleIO GameState
wrong ans
= do PutStr ("Wrong, the answer is " ++ show ans ++ "\n")
st <- GetGameState
PutGameState (addWrong st)
quiz
data Input = Answer Int
| QuitCmd
readInput : (prompt : String) -> Command Input
readInput prompt
= do PutStr prompt
answer <- GetLine
if toLower answer == "quit"
then Pure QuitCmd
else Pure (Answer (cast answer))
quiz : ConsoleIO GameState
quiz = do num1 <- GetRandom
num2 <- GetRandom
st <- GetGameState
PutStr (show st ++ "\n")
input <- readInput (show num1 ++ " * " ++ show num2 ++ "? ")
case input of
Answer answer => if answer == num1 * num2
then correct
else wrong (num1 * num2)
QuitCmd => Quit st
partial
main : IO ()
main = do seed <- time
(Just score, _, state) <-
run forever (randoms (fromInteger seed)) initState quiz
| _ => putStrLn "Ran out of fuel"
putStrLn ("Final score: " ++ show state)
================================================
FILE: Chapter12/DataStore.idr
================================================
module Main
import Data.Vect
infixr 5 .+.
data Schema = SString | SInt | (.+.) Schema Schema
SchemaType : Schema -> Type
SchemaType SString = String
SchemaType SInt = Int
SchemaType (x .+. y) = (SchemaType x, SchemaType y)
record DataStore (size : Nat) where
constructor MkData
schema : Schema
items : Vect size (SchemaType schema)
setSchema : DataStore 0 -> Schema -> DataStore 0
setSchema (MkData schema []) schema' = MkData schema' []
data Command : Schema -> Type where
SetSchema : Schema -> Command schema
Add : SchemaType schema -> Command schema
Get : Integer -> Command schema
Quit : Command schema
================================================
FILE: Chapter12/Exercises/ex_12_1.idr
================================================
import Control.Monad.State
data Tree a = Empty
| Node (Tree a) a (Tree a)
testTree : Tree String
testTree = Node (Node (Node Empty "Jim" Empty) "Fred"
(Node Empty "Sheila" Empty)) "Alice"
(Node Empty "Bob" (Node Empty "Eve" Empty))
{- 1 -}
update : (stateType -> stateType) -> State stateType ()
update f = do st <- get
put (f st)
increment : Nat -> State Nat ()
increment x = update (+x)
{- 2 -}
countEmpty : Tree a -> State Nat ()
countEmpty Empty = update (+1)
countEmpty (Node left val right) = do countEmpty left
countEmpty right
{- 3 -}
countEmptyNode : Tree a -> State (Nat, Nat) ()
countEmptyNode Empty = do (empty, nodes) <- get
put (empty + 1, nodes)
countEmptyNode (Node left val right) = do countEmptyNode left
(empty, nodes) <- get
put (empty, nodes + 1)
countEmptyNode right
================================================
FILE: Chapter12/Exercises/ex_12_3a.idr
================================================
import Data.Primitives.Views
import System
%default total
record Score where
constructor MkScore
correct : Nat
attempted : Nat
record GameState where
constructor MkGameState
score : Score
difficulty : Int
Show GameState where
show st = show (correct (score st)) ++ "/"
++ show (attempted (score st)) ++ "\n"
++ "Difficulty: " ++ show (difficulty st)
initState : GameState
initState = MkGameState (MkScore 0 0) 12
addWrong : GameState -> GameState
addWrong = record { score->attempted $= (+1) }
addCorrect : GameState -> GameState
addCorrect = record { score->correct $= (+1),
score->attempted $= (+1) }
setDifficulty : Int -> GameState -> GameState
setDifficulty newDiff state = record { difficulty = newDiff } state
data Command : Type -> Type where
PutStr : String -> Command ()
GetLine : Command String
GetRandom : Command Int
GetGameState : Command GameState
PutGameState : GameState -> Command ()
Pure : ty -> Command ty
Bind : Command a -> (a -> Command b) -> Command b
data ConsoleIO : Type -> Type where
Quit : a -> ConsoleIO a
Do : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b
namespace ConsoleDo
(>>=) : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b
(>>=) = Do
{- 2 -}
mutual
Functor Command where
map func x = do x' <- x
pure (func x')
Applicative Command where
pure = Pure
(<*>) f a = do f' <- f
a' <- a
pure (f' a')
Monad Command where
(>>=) = Bind
randoms : Int -> Stream Int
randoms seed = let seed' = 1664525 * seed + 1013904223 in
(seed' `shiftR` 2) :: randoms seed'
runCommand : Stream Int -> GameState -> Command a ->
IO (a, Stream Int, GameState)
runCommand rnds state (PutStr x) = do putStr x
pure ((), rnds, state)
runCommand rnds state GetLine = do str <- getLine
pure (str, rnds, state)
runCommand (val :: rnds) state GetRandom
= pure (getRandom val (difficulty state), rnds, state)
where
getRandom : Int -> Int -> Int
getRandom val max with (divides val max)
getRandom val 0 | DivByZero = 1
getRandom ((max * div) + rem) max | (DivBy prf) = abs rem + 1
runCommand rnds state GetGameState
= pure (state, rnds, state)
runCommand rnds state (PutGameState newState)
= pure ((), rnds, newState)
runCommand rnds state (Pure val)
= pure (val, rnds, state)
runCommand rnds state (Bind c f)
= do (res, newRnds, newState) <- runCommand rnds state c
runCommand newRnds newState (f res)
data Fuel = Dry | More (Lazy Fuel)
partial
forever : Fuel
forever = More forever
run : Fuel -> Stream Int -> GameState -> ConsoleIO a ->
IO (Maybe a, Stream Int, GameState)
run fuel rnds state (Quit val) = do pure (Just val, rnds, state)
run (More fuel) rnds state (Do c f)
= do (res, newRnds, newState) <- runCommand rnds state c
run fuel newRnds newState (f res)
run Dry rnds state p = pure (Nothing, rnds, state)
{- 1 -}
updateGameState : (GameState -> GameState) -> Command ()
updateGameState f = do st <- GetGameState
PutGameState (f st)
mutual
correct : ConsoleIO GameState
correct = do PutStr "Correct!\n"
updateGameState addCorrect
quiz
wrong : Int -> ConsoleIO GameState
wrong ans
= do PutStr ("Wrong, the answer is " ++ show ans ++ "\n")
updateGameState addWrong
quiz
data Input = Answer Int
| QuitCmd
readInput : (prompt : String) -> Command Input
readInput prompt
= do PutStr prompt
answer <- GetLine
if toLower answer == "quit"
then Pure QuitCmd
else Pure (Answer (cast answer))
quiz : ConsoleIO GameState
quiz = do num1 <- GetRandom
num2 <- GetRandom
st <- GetGameState
PutStr (show st ++ "\n")
input <- readInput (show num1 ++ " * " ++ show num2 ++ "? ")
case input of
Answer answer => if answer == num1 * num2
then correct
else wrong (num1 * num2)
QuitCmd => Quit st
partial
main : IO ()
main = do seed <- time
(Just score, _, state) <-
run forever (randoms (fromInteger seed)) initState quiz
| _ => putStrLn "Ran out of fuel"
putStrLn ("Final score: " ++ show state)
================================================
FILE: Chapter12/Exercises/ex_12_3b.idr
================================================
record Votes where
constructor MkVotes
upvotes : Integer
downvotes : Integer
record Article where
constructor MkArticle
title : String
url : String
score : Votes
initPage : (title : String) -> (url : String) -> Article
initPage title url = MkArticle title url (MkVotes 0 0)
badSite : Article
badSite = MkArticle "Bad Page" "http://example.com/bad" (MkVotes 5 47)
goodSite : Article
goodSite = MkArticle "Good Page" "http://example.com/good" (MkVotes 101 7)
{- 3 -}
getScore : Article -> Integer
getScore article = upvotes (score article) - downvotes (score article)
{- 4 -}
addUpvote : Article -> Article
addUpvote = record { score->upvotes $= (+1) }
addDownvote : Article -> Article
addDownvote = record { score->downvotes $= (+1) }
================================================
FILE: Chapter12/Record.idr
================================================
record Book where
constructor MkBook
title : String
author : String
record Album where
constructor MkAlbum
title : String
tracks : List String
================================================
FILE: Chapter12/State.idr
================================================
import Control.Monad.State
increment : Nat -> State Nat ()
increment inc = do current <- get
put (current + inc)
================================================
FILE: Chapter12/StateMonad.idr
================================================
data State : (stateType : Type) -> Type -> Type where
Get : State stateType stateType
Put : stateType -> State stateType ()
Pure : ty -> State stateType ty
Bind : State stateType a -> (a -> State stateType b) ->
State stateType b
get : State stateType stateType
get = Get
put : stateType -> State stateType ()
put = Put
mutual
Functor (State stateType) where
map func x = do val <- x
pure (func val)
Applicative (State stateType) where
pure = Pure
(<*>) f a = do f' <- f
a' <- a
pure (f' a')
Monad (State stateType) where
(>>=) = Bind
{-
(>>=) : State stateType a -> (a -> State stateType b) ->
State stateType b
(>>=) = Bind
-}
runState : State stateType a -> (st : stateType) -> (a, stateType)
runState Get st = (st, st)
runState (Put newState) st = ((), newState)
runState (Pure x) st = (x, st)
runState (Bind cmd prog) st = let (val, nextState) = runState cmd st in
runState (prog val) nextState
addIfPositive : Integer -> State Integer Bool
addIfPositive val = do when (val > 0) $
do current <- get
put (current + val)
pure (val > 0)
addPositives : List Integer -> State Integer Nat
addPositives vals = do added <- traverse addIfPositive vals
pure (length (filter id added))
================================================
FILE: Chapter12/Traverse.idr
================================================
crew : List String
crew = ["Lister", "Rimmer", "Kryten", "Cat"]
main : IO ()
main = do putStr "Display Crew? "
x <- getLine
when (x == "yes") $
do traverse putStrLn crew
pure ()
putStrLn "Done"
================================================
FILE: Chapter12/TreeLabel.idr
================================================
data Tree a = Empty
| Node (Tree a) a (Tree a)
testTree : Tree String
testTree = Node (Node (Node Empty "Jim" Empty) "Fred"
(Node Empty "Sheila" Empty)) "Alice"
(Node Empty "Bob" (Node Empty "Eve" Empty))
flatten : Tree a -> List a
flatten Empty = []
flatten (Node left val right) = flatten left ++ val :: flatten right
treeLabelWith : Stream labelType -> Tree a ->
(Stream labelType, Tree (labelType, a))
treeLabelWith lbls Empty = (lbls, Empty)
treeLabelWith lbls (Node left val right)
= let (this :: lblsLeft, left_labelled) = treeLabelWith lbls left
(lblsRight, right_labelled) = treeLabelWith lblsLeft right
in
(lblsRight, Node left_labelled (this, val) right_labelled)
treeLabel : Tree a -> Tree (Integer, a)
treeLabel tree = snd (treeLabelWith [1..] tree)
================================================
FILE: Chapter12/TreeLabelState.idr
================================================
import Control.Monad.State
data Tree a = Empty
| Node (Tree a) a (Tree a)
testTree : Tree String
testTree = Node (Node (Node Empty "Jim" Empty) "Fred"
(Node Empty "Sheila" Empty)) "Alice"
(Node Empty "Bob" (Node Empty "Eve" Empty))
flatten : Tree a -> List a
flatten Empty = []
flatten (Node left val right) = flatten left ++ val :: flatten right
treeLabelWith : Tree a -> State (Stream labelType) (Tree (labelType, a))
treeLabelWith Empty = pure Empty
treeLabelWith (Node left val right)
= do left_labelled <- treeLabelWith left
(this :: rest) <- get
put rest
right_labelled <- treeLabelWith right
pure (Node left_labelled (this, val) right_labelled)
treeLabel : Tree a -> Tree (Integer, a)
treeLabel tree = evalState (treeLabelWith tree) [1..]
================================================
FILE: Chapter12/TreeLabelType.idr
================================================
data Tree a = Empty
| Node (Tree a) a (Tree a)
testTree : Tree String
testTree = Node (Node (Node Empty "Jim" Empty) "Fred"
(Node Empty "Sheila" Empty)) "Alice"
(Node Empty "Bob" (Node Empty "Eve" Empty))
flatten : Tree a -> List a
flatten Empty = []
flatten (Node left val right) = flatten left ++ val :: flatten right
data State : (stateType : Type) -> Type -> Type where
Get : State stateType stateType
Put : stateType -> State stateType ()
Pure : ty -> State stateType ty
Bind : State stateType a -> (a -> State stateType b) ->
State stateType b
{-
(>>=) : State stateType a -> (a -> State stateType b) ->
State stateType b
(>>=) = Bind
-}
mutual
Functor (State stateType) where
map func x = do val <- x
Pure (func val)
Applicative (State stateType) where
pure x = Pure x
(<*>) f a = do func <- f
arg <- a
pure (func arg)
Monad (State stateType) where
(>>=) = Bind
runState : State stateType a -> (st : stateType) -> (a, stateType)
runState Get st = (st, st)
runState (Put newState) st = ((), newState)
runState (Pure x) st = (x, st)
runState (Bind cmd prog) st = let (val, nextState) = runState cmd st in
runState (prog val) nextState
treeLabelWith : Tree a -> State (Stream labelType) (Tree (labelType, a))
treeLabelWith Empty = Pure Empty
treeLabelWith (Node left val right)
= do left_labelled <- treeLabelWith left
(this :: rest) <- Get
Put rest
right_labelled <- treeLabelWith right
Pure (Node left_labelled (this, val) right_labelled)
treeLabel : Tree a -> Tree (Integer, a)
treeLabel tree = fst (runState (treeLabelWith tree) [1..])
================================================
FILE: Chapter13/Door.idr
================================================
data DoorState = DoorOpen | DoorClosed
data DoorCmd : Type -> DoorState -> DoorState -> Type where
Open : DoorCmd () DoorClosed DoorOpen
Close : DoorCmd () DoorOpen DoorClosed
RingBell : DoorCmd () DoorClosed DoorClosed
Pure : ty -> DoorCmd ty state state
(>>=) : DoorCmd a state1 state2 ->
(a -> DoorCmd b state2 state3) ->
DoorCmd b state1 state3
doorProg : DoorCmd () DoorClosed DoorClosed
doorProg = do RingBell
Open
Close
================================================
FILE: Chapter13/Exercises/ex_13_1.idr
================================================
namespace Q1
data DoorState = DoorOpen | DoorClosed
data DoorCmd : Type -> DoorState -> DoorState -> Type where
Open : DoorCmd () DoorClosed DoorOpen
Close : DoorCmd () DoorOpen DoorClosed
RingBell : DoorCmd () state state
Pure : ty -> DoorCmd ty state state
(>>=) : DoorCmd a state1 state2 ->
(a -> DoorCmd b state2 state3) ->
DoorCmd b state1 state3
doorProg : DoorCmd () DoorClosed DoorClosed
doorProg = do RingBell
Open
RingBell
Close
namespace Q2
data GuessCmd : Type -> Nat -> Nat -> Type where
Try : Integer -> GuessCmd Ordering (S guesses) guesses
Pure : ty -> GuessCmd ty state state
(>>=) : GuessCmd a state1 state2 ->
(a -> GuessCmd b state2 state3) ->
GuessCmd b state1 state3
threeGuesses : GuessCmd () 3 0
threeGuesses = do Try 10
Try 20
Try 15
Pure ()
{-
no_guesses : GuessCmd () 0 0
no_guesses = do Try 10
Pure ()
-}
namespace Q3
data Matter = Solid | Liquid | Gas
data MatterCmd : Type -> Matter -> Matter -> Type where
Melt : MatterCmd () Solid Liquid
Boil : MatterCmd () Liquid Gas
Condense : MatterCmd () Gas Liquid
Freeze : MatterCmd () Liquid Solid
Pure : ty -> MatterCmd ty state state
(>>=) : MatterCmd a state1 state2 ->
(a -> MatterCmd b state2 state3) ->
MatterCmd b state1 state3
iceSteam : MatterCmd () Solid Gas
iceSteam = do Melt
Boil
steamIce : MatterCmd () Gas Solid
steamIce = do Condense
Freeze
{-
overMelt : MatterCmd () Solid Gas
overMelt = do Melt
Melt
-}
================================================
FILE: Chapter13/Exercises/ex_13_2.idr
================================================
import Data.Vect
data StackCmd : Type -> Nat -> Nat -> Type where
Push : Integer -> StackCmd () height (S height)
Pop : StackCmd Integer (S height) height
Top : StackCmd Integer (S height) (S height)
GetStr : StackCmd String height height
PutStr : String -> StackCmd () height height
Pure : ty -> StackCmd ty height height
(>>=) : StackCmd a height1 height2 ->
(a -> StackCmd b height2 height3) ->
StackCmd b height1 height3
runStack : (stk : Vect inHeight Integer) ->
StackCmd ty inHeight outHeight -> IO (ty, Vect outHeight Integer)
runStack stk (Push val) = pure ((), val :: stk)
runStack (val :: stk) Pop = pure (val, stk)
runStack (val :: stk) Top = pure (val, val :: stk)
runStack stk GetStr = do x <- getLine
pure (x, stk)
runStack stk (PutStr x) = do putStr x
pure ((), stk)
runStack stk (Pure x) = pure (x, stk)
runStack stk (x >>= f) = do (x', newStk) <- runStack stk x
runStack newStk (f x')
data StackIO : Nat -> Type where
Do : StackCmd a height1 height2 ->
(a -> Inf (StackIO height2)) -> StackIO height1
namespace StackDo
(>>=) : StackCmd a height1 height2 ->
(a -> Inf (StackIO height2)) -> StackIO height1
(>>=) = Do
data Fuel = Dry | More (Lazy Fuel)
partial
forever : Fuel
forever = More forever
run : Fuel -> Vect height Integer -> StackIO height -> IO ()
run (More fuel) stk (Do c f)
= do (res, newStk) <- runStack stk c
run fuel newStk (f res)
run Dry stk p = pure ()
doAdd : StackCmd () (S (S height)) (S height)
doAdd = do val1 <- Pop
val2 <- Pop
Push (val1 + val2)
doSub : StackCmd () (S (S height)) (S height)
doSub = do val1 <- Pop
val2 <- Pop
Push (val2 - val1)
doMul : StackCmd () (S (S height)) (S height)
doMul = do val1 <- Pop
val2 <- Pop
Push (val1 * val2)
mutual
tryAdd : StackIO height
tryAdd {height = (S (S h))} = do doAdd
result <- Top
PutStr (show result ++ "\n")
stackCalc
tryAdd = do PutStr "Fewer than two items on the stack\n"
stackCalc
trySub : StackIO height
trySub {height = (S (S h))} = do doSub
result <- Top
PutStr (show result ++ "\n")
stackCalc
trySub = do PutStr "Fewer than two items on the stack\n"
stackCalc
tryMul : StackIO height
tryMul {height = (S (S h))} = do doMul
result <- Top
PutStr (show result ++ "\n")
stackCalc
tryMul = do PutStr "Fewer than two items on the stack\n"
stackCalc
tryNeg : StackIO height
tryNeg {height = (S h)} = do x <- Pop
Push (-x)
result <- Top
PutStr (show result ++ "\n")
stackCalc
tryNeg = do PutStr "Nothing on the stack\n"
stackCalc
tryDup : StackIO height
tryDup {height = (S h)} = do x <- Top
Push x
PutStr ("Duplicated " ++ show x ++ "\n")
stackCalc
tryDup = do PutStr "Nothing on the stack\n"
stackCalc
tryDiscard : StackIO height
tryDiscard {height = (S h)} = do x <- Pop
PutStr ("Discarded " ++ show x ++ "\n")
stackCalc
tryDiscard = do PutStr "Nothing on the stack\n"
stackCalc
data StkInput = Number Integer
| Add
| Subtract
| Multiply
| Negate
| Discard
| Duplicate
strToInput : String -> Maybe StkInput
strToInput "add" = Just Add
strToInput "subtract" = Just Subtract
strToInput "multiply" = Just Multiply
strToInput "negate" = Just Negate
strToInput "discard" = Just Discard
strToInput "duplicate" = Just Duplicate
strToInput x = if all isDigit (unpack x)
then Just (Number (cast x))
else Nothing
stackCalc : StackIO height
stackCalc = do PutStr "> "
input <- GetStr
case strToInput input of
Nothing => do PutStr "Invalid input\n"
stackCalc
Just (Number x) => do Push x
stackCalc
Just Add => tryAdd
Just Subtract => trySub
Just Multiply => tryMul
Just Negate => tryNeg
Just Discard => tryDiscard
Just Duplicate => tryDup
main : IO ()
main = run forever [] stackCalc
================================================
FILE: Chapter13/Stack.idr
================================================
import Data.Vect
data StackCmd : Type -> Nat -> Nat -> Type where
Push : Integer -> StackCmd () height (S height)
Pop : StackCmd Integer (S height) height
Top : StackCmd Integer (S height) (S height)
Pure : ty -> StackCmd ty height height
(>>=) : StackCmd a height1 height2 ->
(a -> StackCmd b height2 height3) ->
StackCmd b height1 height3
runStack : (stk : Vect inHeight Integer) ->
StackCmd ty inHeight outHeight ->
(ty, Vect outHeight Integer)
runStack stk (Push val) = ((), val :: stk)
runStack (val :: stk) Pop = (val, stk)
runStack (val :: stk) Top = (val, val :: stk)
runStack stk (Pure x) = (x, stk)
runStack stk (x >>= f) = let (x', newStk) = runStack stk x in
runStack newStk (f x')
testAdd : StackCmd Integer 0 0
testAdd = do Push 10
-- Push 20
val1 <- Pop
val2 <- Pop
Pure (val1 + val2)
doAdd : StackCmd () (S (S height)) (S height)
doAdd = do val1 <- Pop
val2 <- Pop
Push (val1 + val2)
================================================
FILE: Chapter13/StackIO.idr
================================================
import Data.Vect
data StackCmd : Type -> Nat -> Nat -> Type where
Push : Integer -> StackCmd () height (S height)
Pop : StackCmd Integer (S height) height
Top : StackCmd Integer (S height) (S height)
GetStr : StackCmd String height height
PutStr : String -> StackCmd () height height
Pure : ty -> StackCmd ty height height
(>>=) : StackCmd a height1 height2 ->
(a -> StackCmd b height2 height3) ->
StackCmd b height1 height3
runStack : (stk : Vect inHeight Integer) ->
StackCmd ty inHeight outHeight -> IO (ty, Vect outHeight Integer)
runStack stk (Push val) = pure ((), val :: stk)
runStack (val :: stk) Pop = pure (val, stk)
runStack (val :: stk) Top = pure (val, val :: stk)
runStack stk GetStr = do x <- getLine
pure (x, stk)
runStack stk (PutStr x) = do putStr x
pure ((), stk)
runStack stk (Pure x) = pure (x, stk)
runStack stk (x >>= f) = do (x', newStk) <- runStack stk x
runStack newStk (f x')
testAdd : StackCmd () 0 0
testAdd = do Push 10
x <- GetStr
Push (cast x)
val1 <- Pop
val2 <- Pop
PutStr (show (val1 + val2) ++ "\n")
data StackIO : Nat -> Type where
Do : StackCmd a height1 height2 ->
(a -> Inf (StackIO height2)) -> StackIO height1
namespace StackDo
(>>=) : StackCmd a height1 height2 ->
(a -> Inf (StackIO height2)) -> StackIO height1
(>>=) = Do
data Fuel = Dry | More (Lazy Fuel)
partial
forever : Fuel
forever = More forever
run : Fuel -> Vect height Integer -> StackIO height -> IO ()
run (More fuel) stk (Do c f)
= do (res, newStk) <- runStack stk c
run fuel newStk (f res)
run Dry stk p = pure ()
doAdd : StackCmd () (S (S height)) (S height)
doAdd = do val1 <- Pop
val2 <- Pop
Push (val1 + val2)
mutual
tryAdd : StackIO height
tryAdd {height = (S (S h))} = do doAdd
result <- Top
PutStr (show result ++ "\n")
stackCalc
tryAdd = do PutStr "Fewer than two items on the stack\n"
stackCalc
data StkInput = Number Integer
| Add
strToInput : String -> Maybe StkInput
strToInput "" = Nothing
strToInput "add" = Just Add
strToInput x = if all isDigit (unpack x)
then Just (Number (cast x))
else Nothing
stackCalc : StackIO height
stackCalc = do PutStr "> "
input <- GetStr
case strToInput input of
Nothing => do PutStr "Invalid input\n"
stackCalc
Just (Number x) => do Push x
stackCalc
Just Add => tryAdd
main : IO ()
main = run forever [] stackCalc
================================================
FILE: Chapter13/Vending.idr
================================================
VendState : Type
VendState = (Nat, Nat)
data Input = COIN
| VEND
| CHANGE
| REFILL Nat
strToInput : String -> Maybe Input
strToInput "insert" = Just COIN
strToInput "vend" = Just VEND
strToInput "change" = Just CHANGE
strToInput x = if all isDigit (unpack x)
then Just (REFILL (cast x))
else Nothing
data MachineCmd : Type -> VendState -> VendState -> Type where
InsertCoin : MachineCmd () (pounds, chocs) (S pounds, chocs)
Vend : MachineCmd () (S pounds, S chocs) (pounds, chocs)
GetCoins : MachineCmd () (pounds, chocs) (Z, chocs)
Display : String ->
MachineCmd () state state
Refill : (bars : Nat) ->
MachineCmd () (Z, chocs) (Z, bars + chocs)
GetInput : MachineCmd (Maybe Input) state state
Pure : ty -> MachineCmd ty state state
(>>=) : MachineCmd a state1 state2 -> (a -> MachineCmd b state2 state3) ->
MachineCmd b state1 state3
data MachineIO : VendState -> Type where
Do : MachineCmd a state1 state2 ->
(a -> Inf (MachineIO state2)) -> MachineIO state1
runMachine : MachineCmd ty inState outState -> IO ty
runMachine InsertCoin = putStrLn "Coin inserted"
runMachine Vend = putStrLn "Please take your chocolate"
runMachine {inState = (pounds, _)} GetCoins
= putStrLn (show pounds ++ " coins returned")
runMachine (Display str) = putStrLn str
runMachine (Refill bars)
= putStrLn ("Chocolate remaining: " ++ show bars)
runMachine {inState = (pounds, chocs)} GetInput
= do putStrLn ("Coins: " ++ show pounds ++ "; " ++
"Stock: " ++ show chocs)
putStr "> "
x <- getLine
pure (strToInput x)
runMachine (Pure x) = pure x
runMachine (cmd >>= prog) = do x <- runMachine cmd
runMachine (prog x)
data Fuel = Dry | More (Lazy Fuel)
partial
forever : Fuel
forever = More forever
run : Fuel -> MachineIO state -> IO ()
run (More fuel) (Do c f)
= do res <- runMachine c
run fuel (f res)
run Dry p = pure ()
namespace MachineDo
(>>=) : MachineCmd a state1 state2 ->
(a -> Inf (MachineIO state2)) -> MachineIO state1
(>>=) = Do
mutual
vend : MachineIO (pounds, chocs)
vend {pounds = S p} {chocs = S c} = do Vend
Display "Enjoy!"
machineLoop
vend {pounds = Z} = do Display "Insert a coin"
machineLoop
vend {chocs = Z} = do Display "Out of stock"
machineLoop
refill : (num : Nat) -> MachineIO (pounds, chocs)
refill {pounds = Z} num = do Refill num
machineLoop
refill _ = do Display "Can't refill: Coins in machine"
machineLoop
machineLoop : MachineIO (pounds, chocs)
machineLoop =
do Just x <- GetInput | Nothig => do Display "Invalid input"
machineLoop
case x of
COIN => do InsertCoin
machineLoop
VEND => vend
CHANGE => do GetCoins
Display "Change returned"
machineLoop
REFILL num => refill num
main : IO ()
main = run forever (machineLoop {pounds = 0} {chocs = 1})
================================================
FILE: Chapter14/ATM.idr
================================================
import Data.Vect
data ATMState = Ready | CardInserted | Session
data PINCheck = CorrectPIN | IncorrectPIN
PIN : Type
PIN = Vect 4 Char
data HasCard : ATMState -> Type where
HasCI : HasCard CardInserted
HasSession : HasCard Session
data ATMCmd : (res : Type) -> ATMState -> (res -> ATMState) -> Type where
InsertCard : ATMCmd () Ready (const CardInserted)
EjectCard : {auto prf : HasCard state} ->
ATMCmd () state (const Ready)
GetPIN : ATMCmd PIN CardInserted (const CardInserted)
CheckPIN : PIN -> ATMCmd PINCheck CardInserted
(\check => case check of
CorrectPIN => Session
IncorrectPIN => CardInserted)
GetAmount : ATMCmd Nat state (const state)
Dispense : (amount : Nat) -> ATMCmd () Session (const Session)
Message : String -> ATMCmd () state (const state)
Pure : (res : ty) -> ATMCmd ty (state_fn res) state_fn
(>>=) : ATMCmd a state1 state2_fn ->
((res : a) -> ATMCmd b (state2_fn res) state3_fn) ->
ATMCmd b state1 state3_fn
readVect : (n : Nat) -> IO (Vect n Char)
readVect Z = do discard <- getLine -- rest of input up to enter
pure []
readVect (S k) = do ch <- getChar
chs <- readVect k
pure (ch :: chs)
testPIN : Vect 4 Char
testPIN = ['1', '2', '3', '4']
insertEject : ATMCmd () Ready (const Ready)
insertEject = do InsertCard
EjectCard -- ?insertEject_rhs
-- badATM : ATMCmd () Ready (const Ready)
-- badATM = EjectCard
runATM : ATMCmd res instate outstate_fn -> IO res
runATM InsertCard = do putStrLn "Please insert your card (press enter)"
x <- getLine
pure ()
runATM EjectCard = putStrLn "Card ejected"
runATM GetPIN = do putStr "Enter PIN: "
readVect 4
runATM (CheckPIN pin) = if pin == testPIN
then pure CorrectPIN
else pure IncorrectPIN
runATM GetAmount = do putStr "How much would you like? "
x <- getLine
pure (cast x)
runATM (Dispense amount) = putStrLn ("Here is " ++ show amount)
runATM (Message msg) = putStrLn msg
runATM (Pure res) = pure res
runATM (x >>= f) = do x' <- runATM x
runATM (f x')
atm : ATMCmd () Ready (const Ready)
atm = do InsertCard
pin <- GetPIN
pinOK <- CheckPIN pin
case pinOK of
CorrectPIN => do cash <- GetAmount
Dispense cash
EjectCard
IncorrectPIN => EjectCard
atm_alt : ATMCmd () Ready (const Ready)
atm_alt = do InsertCard
pin <- GetPIN
cash <- GetAmount
pinOK <- CheckPIN pin
Message "Checking Card"
case pinOK of
CorrectPIN => do Dispense cash
EjectCard
Message "Please remove your card and cash"
IncorrectPIN => do Message "Incorrect PIN"
EjectCard
================================================
FILE: Chapter14/DoorJam.idr
================================================
data DoorState = DoorOpen | DoorClosed
data DoorResult = OK | Jammed
data DoorCmd : (ty : Type) -> DoorState -> (ty -> DoorState) -> Type where
Open : DoorCmd DoorResult DoorClosed
(\res => case res of
OK => DoorOpen
Jammed => DoorClosed)
Close : DoorCmd () DoorOpen (const DoorClosed)
RingBell : DoorCmd () DoorClosed (const DoorClosed)
Display : String -> DoorCmd () state (const state)
Pure : (res : ty) -> DoorCmd ty (state_fn res) state_fn
(>>=) : DoorCmd a state1 state2_fn ->
((res : a) -> DoorCmd b (state2_fn res) state3_fn) ->
DoorCmd b state1 state3_fn
logOpen : DoorCmd DoorResult DoorClosed
(\res => case res of
OK => DoorOpen
Jammed => DoorClosed)
logOpen = do Display "Trying to open the door"
OK <- Open | Jammed => do Display "Jammed"
Pure Jammed
Display "Success"
Pure OK
doorProg : DoorCmd () DoorClosed (const DoorClosed)
doorProg = do RingBell
jam <- Open
Display "Trying to open the door"
case jam of
OK => do Display "Glad To Be Of Service"
Close
Jammed => Display "Door Jammed"
doorProg2 : DoorCmd () DoorClosed (const DoorClosed)
doorProg2 = do RingBell
OK <- Open | Jammed => Display "Door Jammed"
Display "Glad To Be Of Service"
Close
OK <- Open | Jammed => Display "Door Jammed"
Display "Glad To Be Of Service"
Close
================================================
FILE: Chapter14/Exercises/ex_14_2_1.idr
================================================
data Access = LoggedOut | LoggedIn
data PwdCheck = Correct | Incorrect
data ShellCmd : (ty : Type) -> Access -> (ty -> Access) -> Type where
Password : String -> ShellCmd PwdCheck LoggedOut
(\res => case res of
Correct => LoggedIn
Incorrect => LoggedOut)
Logout : ShellCmd () LoggedIn (const LoggedOut)
GetSecret : ShellCmd String LoggedIn (const LoggedIn)
PutStr : String -> ShellCmd () state (const state)
Pure : (res : ty) -> ShellCmd ty (state_fn res) state_fn
(>>=) : ShellCmd a state1 state2_fn ->
((res : a) -> ShellCmd b (state2_fn res) state3_fn) ->
ShellCmd b state1 state3_fn
session : ShellCmd () LoggedOut (const LoggedOut)
session = do Correct <- Password "wurzel"
| Incorrect => PutStr "Wrong password"
msg <- GetSecret
PutStr ("Secret code: " ++ show msg ++ "\n")
Logout
{-
badSession : ShellCmd () LoggedOut (const LoggedOut)
badSession = do Password "wurzel"
msg <- GetSecret
PutStr ("Secret code: " ++ show msg ++ "\n")
Logout
noLogout : ShellCmd () LoggedOut (const LoggedOut)
noLogout = do Correct <- Password "wurzel"
| Incorrect => PutStr "Wrong password"
msg <- GetSecret
PutStr ("Secret code: " ++ show msg ++ "\n")
-}
================================================
FILE: Chapter14/Exercises/ex_14_2_2.idr
================================================
VendState : Type
VendState = (Nat, Nat)
data Input = COIN
| VEND
| CHANGE
| REFILL Nat
strToInput : String -> Maybe Input
strToInput "insert" = Just COIN
strToInput "vend" = Just VEND
strToInput "change" = Just CHANGE
strToInput x = if all isDigit (unpack x)
then Just (REFILL (cast x))
else Nothing
data CoinResult = Inserted | Rejected
data MachineCmd : (res : Type) -> VendState -> (res -> VendState) -> Type where
InsertCoin : MachineCmd CoinResult (pounds, chocs)
(\res => case res of
Inserted => (S pounds, chocs)
Rejected => (pounds, chocs))
Vend : MachineCmd () (S pounds, S chocs) (const (pounds, chocs))
GetCoins : MachineCmd () (pounds, chocs) (const (Z, chocs))
Display : String ->
MachineCmd () state (const state)
Refill : (bars : Nat) ->
MachineCmd () (Z, chocs) (const (Z, bars + chocs))
GetInput : MachineCmd (Maybe Input) state (const state)
Pure : (res : ty) -> MachineCmd ty (state_fn res) state_fn
(>>=) : MachineCmd a state1 state2_fn ->
((x : a) -> MachineCmd b (state2_fn x) state3_fn) ->
MachineCmd b state1 state3_fn
data MachineIO : VendState -> Type where
Do : MachineCmd a state1 state2_fn ->
((x : a) -> Inf (MachineIO (state2_fn x))) -> MachineIO state1
namespace MachineDo
(>>=) : MachineCmd a state1 state2_fn ->
((x : a) -> Inf (MachineIO (state2_fn x))) -> MachineIO state1
(>>=) = Do
mutual
vend : MachineIO (pounds, chocs)
vend {pounds = S p} {chocs = S c} = do Vend
Display "Enjoy!"
machineLoop
vend {pounds = Z} = do Display "Insert a coin"
machineLoop
vend {chocs = Z} = do Display "Out of stock"
machineLoop
refill : (num : Nat) -> MachineIO (pounds, chocs)
refill {pounds = Z} num = do Refill num
machineLoop
refill _ = do Display "Can't refill: Coins in machine"
machineLoop
machineLoop : MachineIO (pounds, chocs)
machineLoop =
do Just x <- GetInput | Nothig => do Display "Invalid input"
machineLoop
case x of
COIN => do res <- InsertCoin
case res of
Inserted => do Display "Coin inserted"
machineLoop
Rejected => do Display "Coin rejected"
machineLoop
VEND => vend
CHANGE => do GetCoins
Display "Change returned"
machineLoop
REFILL num => refill num
================================================
FILE: Chapter14/Hangman.idr
================================================
import Data.Vect
%default total
data GameState : Type where
NotRunning : GameState
Running : (guesses : Nat) -> (letters : Nat) -> GameState
letters : String -> List Char
letters str = nub (map toUpper (unpack str))
data GuessResult = Correct | Incorrect
data GameCmd : (ty : Type) -> GameState -> (ty -> GameState) -> Type where
NewGame : (word : String) ->
GameCmd ()
NotRunning
(const (Running 6 (length (letters word))))
Won : GameCmd () (Running (S guesses) 0)
(const NotRunning)
Lost : GameCmd () (Running 0 (S guesses))
(const NotRunning)
Guess : (c : Char) ->
GameCmd GuessResult
(Running (S guesses) (S letters))
(\res => case res of
Correct => Running (S guesses) letters
Incorrect => Running guesses (S letters))
ShowState : GameCmd () state (const state)
Message : String -> GameCmd () state (const state)
ReadGuess : GameCmd Char state (const state)
Pure : (res : ty) -> GameCmd ty (state_fn res) state_fn
(>>=) : GameCmd a state1 state2_fn ->
((res : a) -> GameCmd b (state2_fn res) state3_fn) ->
GameCmd b state1 state3_fn
namespace Loop
data GameLoop : (ty : Type) -> GameState -> (ty -> GameState) -> Type where
(>>=) : GameCmd a state1 state2_fn ->
((res : a) -> Inf (GameLoop b (state2_fn res) state3_fn)) ->
GameLoop b state1 state3_fn
Exit : GameLoop () NotRunning (const NotRunning)
gameLoop : GameLoop () (Running (S guesses) (S letters)) (const NotRunning)
gameLoop {guesses} {letters} = do
ShowState
g <- ReadGuess
ok <- Guess g
case ok of
Correct => case letters of
Z => do Won
ShowState
Exit
S k => do Message "Correct"
gameLoop
Incorrect => case guesses of
Z => do Lost
ShowState
Exit
(S k) => do Message "Incorrect"
gameLoop
hangman : GameLoop () NotRunning (const NotRunning)
hangman = do NewGame "testing"
gameLoop
data Game : GameState -> Type where
GameStart : Game NotRunning
GameWon : (word : String) -> Game NotRunning
GameLost : (word : String) -> Game NotRunning
InProgress : (word : String) -> (guesses : Nat)
-> (missing : Vect letters Char)
-> Game (Running guesses letters)
Show (Game g) where
show GameStart = "Starting"
show (GameWon word) = "Game won: word was " ++ word
show (GameLost word) = "Game lost: word was " ++ word
show (InProgress word guesses missing)
= "\n" ++ pack (map hideMissing (unpack word))
++ "\n" ++ show guesses ++ " guesses left"
where hideMissing : Char -> Char
hideMissing c = if c `elem` missing then '-' else c
data Fuel = Dry | More (Lazy Fuel)
total
removeElem : (value : a) -> (xs : Vect (S n) a) ->
{auto prf : Elem value xs} ->
Vect n a
removeElem value (value :: ys) {prf = Here} = ys
removeElem {n = Z} value (y :: []) {prf = There later} = absurd later
removeElem {n = (S k)} value (y :: ys) {prf = There later}
= y :: removeElem value ys
data GameResult : (ty : Type) -> (ty -> GameState) -> Type where
OK : (res : ty) -> Game (outstate_fn res) ->
GameResult ty outstate_fn
OutOfFuel : GameResult ty outstate_fn
ok : (res : ty) -> Game (outstate_fn res) ->
IO (GameResult ty outstate_fn)
ok res st = pure (OK res st)
runCmd : Fuel -> Game instate -> GameCmd ty instate outstate_fn ->
IO (GameResult ty outstate_fn)
runCmd fuel state (NewGame word)
= ok () (InProgress (toUpper word) _ (fromList (letters word)))
runCmd fuel (InProgress word _ missing) Won = ok () (GameWon word)
runCmd fuel (InProgress word _ missing) Lost = ok () (GameLost word)
runCmd fuel (InProgress word _ missing) (Guess c)
= case isElem c missing of
Yes prf => ok Correct (InProgress word _ (removeElem c missing))
No contra => ok Incorrect (InProgress word _ missing)
runCmd fuel state ShowState = do printLn state
ok () state
runCmd fuel state (Message str) = do putStrLn str
ok () state
runCmd (More fuel) st ReadGuess = do
putStr "Guess: "
input <- getLine
case unpack input of
[x] => if isAlpha x
then ok (toUpper x) st
else do putStrLn "Invalid input"
runCmd fuel st ReadGuess
_ => do putStrLn "Invalid input"
runCmd fuel st ReadGuess
runCmd fuel state (Pure res) = ok res state
runCmd fuel st (cmd >>= next) = do OK cmdRes newSt <- runCmd fuel st cmd
| OutOfFuel => pure OutOfFuel
runCmd fuel newSt (next cmdRes)
runCmd Dry _ _ = pure OutOfFuel
run : Fuel -> Game instate -> GameLoop ty instate outstate_fn ->
IO (GameResult ty outstate_fn)
run Dry _ _ = pure OutOfFuel
run (More fuel) st (cmd >>= next)
= do OK cmdRes newSt <- runCmd fuel st cmd
| OutOfFuel => pure OutOfFuel
run fuel newSt (next cmdRes)
run (More fuel) st Exit = pure (OK () st)
%default partial
forever : Fuel
forever = More forever
main : IO ()
main = do run forever GameStart hangman
pure ()
================================================
FILE: Chapter15/AdderChannel.idr
================================================
import System.Concurrency.Channels
data Message = Add Nat Nat
adder : IO ()
adder = do Just sender_chan <- listen 1
| Nothing => adder
Just msg <- unsafeRecv Message sender_chan
| Nothing => adder
case msg of
Add x y => do ok <- unsafeSend sender_chan (x + y)
adder
main : IO ()
main = do Just adder_id <- spawn adder
| Nothing => putStrLn "Spawn failed"
Just chan <- connect adder_id
| Nothing => putStrLn "Connection failed"
ok <- unsafeSend chan (Add 2 3)
Just answer <- unsafeRecv String chan
| Nothing => putStrLn "Send failed"
printLn answer
================================================
FILE: Chapter15/ListProc.idr
================================================
import ProcessLib
data ListAction : Type where
Length : List elem -> ListAction
Append : List elem -> List elem -> ListAction
ListType : ListAction -> Type
ListType (Length xs) = Nat
ListType (Append {elem} xs ys) = List elem
total
procList : Service ListType ()
procList = do Respond (\msg => case msg of
Length xs => Pure (length xs)
Append xs ys => Pure (xs ++ ys))
Loop procList
procMain : Client ()
procMain = do Just list <- Spawn procList
| Nothing => Action (putStrLn "Spawn failed")
len <- Request list (Length [1,2,3])
Action (printLn len)
app <- Request list (Append [1,2,3] [4,5,6])
Action (printLn app)
================================================
FILE: Chapter15/Process.idr
================================================
import System.Concurrency.Channels
data Message = Add Nat Nat
data MessagePID = MkMessage PID
data Process : Type -> Type where
Request : MessagePID -> Message -> Process (Maybe Nat)
Respond : ((msg : Message) -> Process Nat) -> Process (Maybe Message)
Spawn : Process () -> Process (Maybe MessagePID)
Loop : Inf (Process a) -> Process a
Action : IO a -> Process a
Pure : a -> Process a
(>>=) : Process a -> (a -> Process b) -> Process b
run : Process t -> IO t
run (Request (MkMessage process) msg)
= do Just chan <- connect process
| _ => pure Nothing
ok <- unsafeSend chan msg
if ok then do Just x <- unsafeRecv Nat chan
| Nothing => pure Nothing
pure (Just x)
else pure Nothing
run (Respond calc)
= do Just sender <- listen 1
| Nothing => pure Nothing -- No incoming connections
Just msg <- unsafeRecv Message sender
| Nothing => pure Nothing -- no message received
res <- run (calc msg)
unsafeSend sender res
pure (Just msg)
run (Spawn proc) = do Just pid <- spawn (run proc)
| Nothing => pure Nothing
pure (Just (MkMessage pid))
run (Loop action) = run action
run (Action act) = act
run (Pure val) = pure val
run (act >>= next) = do x <- run act
run (next x)
procAdder : Process ()
procAdder = do Respond (\msg => case msg of
Add x y => Pure (x + y))
procAdder
procMain : Process ()
procMain = do Just adder_id <- Spawn procAdder
| Nothing => Action (putStrLn "Spawn failed")
Just answer <- Request adder_id (Add 2 3)
| Nothing => Action (putStrLn "Request failed")
Action (printLn answer)
================================================
FILE: Chapter15/ProcessIFace.idr
================================================
import System.Concurrency.Channels
data Message = Add Nat Nat
AdderType : Message -> Type
AdderType (Add x y) = Nat
data ListAction : Type where
Length : List a -> ListAction
Append : List a -> List a -> ListAction
ListType : ListAction -> Type
ListType (Length xs) = Nat
ListType (Append {a} xs ys) = List a
data MessagePID : (iface : reqType -> Type) -> Type where
MkMessage : PID -> MessagePID iface
NoRecv : Void -> Type
NoRecv = const Void
data ProcState = Ready | Sent | Looping
data Process : (iface : reqType -> Type) ->
Type -> ProcState -> ProcState -> Type where
Request : MessagePID service_iface ->
(msg : service_reqType) ->
Process iface (service_iface msg) st st
Respond : ((msg : reqType) -> Process iface (iface msg) Ready Ready) ->
Process iface (Maybe reqType) st Sent
Spawn : Process service_iface () Ready Looping ->
Process iface (Maybe (MessagePID service_iface)) st st
Loop : Inf (Process iface a Ready Looping) ->
Process iface a Sent Looping
Action : IO a -> Process iface a st st
Pure : a -> Process iface a st st
(>>=) : Process iface a st1 st2 -> (a -> Process iface b st2 st3) ->
Process iface b st1 st3
public export
data Fuel = Dry | More (Lazy Fuel)
export partial
forever : Fuel
forever = More forever
total
run : Fuel -> Process iface t in_state out_state -> IO (Maybe t)
run fuel (Request {service_iface} (MkMessage process) msg)
= do Just chan <- connect process
| _ => pure Nothing
ok <- unsafeSend chan msg
if ok then do Just x <- unsafeRecv (service_iface msg) chan
| Nothing => pure Nothing
pure (Just x)
else pure Nothing
run fuel (Respond {reqType} calc)
= do Just sender <- listen 1
| Nothing => pure (Just Nothing)
Just msg <- unsafeRecv reqType sender
| Nothing => pure (Just Nothing)
Just res <- run fuel (calc msg)
| Nothing => pure Nothing
unsafeSend sender res
pure (Just (Just msg))
run (More fuel) (Loop proc) = run fuel proc
run fuel (Spawn proc) = do Just pid <- spawn (do run fuel proc
pure ())
| Nothing => pure (Just Nothing)
pure (Just (Just (MkMessage pid)))
run fuel (Action act) = do res <- act
pure (Just res)
run fuel (Pure val) = pure (Just val)
run fuel (act >>= next) = do Just x <- run fuel act
| Nothing => pure Nothing
run fuel (next x)
run Dry _ = pure Nothing
Service : (iface : reqType -> Type) -> Type -> Type
Service iface a = Process iface a Ready Looping
Client : Type -> Type
Client a = Process NoRecv a Ready Ready
{-
procAdderBad1 : Process () Ready Looping
procAdderBad1 = do Action (putStrLn "I'm out of the office today")
Loop procAdder_bad1
procAdderBad2 : Process () Ready Looping
procAdderBad2 = Loop procAdder_bad2
-}
procAdder : Service AdderType ()
procAdder = do Respond (\msg => case msg of
Add x y => Pure (x + y))
Loop procAdder
procMain : Client ()
procMain = do Just adder_id <- Spawn procAdder
| Nothing => Action (putStrLn "Spawn failed")
answer <- Request adder_id (Add 2 3)
Action (printLn answer)
partial
runProc : Process iface () in_state out_state -> IO ()
runProc proc = do run forever proc
pure ()
main : IO ()
main = runProc procMain
================================================
FILE: Chapter15/ProcessLib.idr
================================================
module ProcessLib
import System.Concurrency.Channels
%default total
export
data MessagePID : (iface : reqType -> Type) -> Type where
MkMessage : PID -> MessagePID iface
public export
NoRecv : Void -> Type
NoRecv = const Void
public export
data ProcState = Ready | Sent | Looping
public export
data Process : (iface : reqType -> Type) ->
Type -> ProcState -> ProcState -> Type where
Request : MessagePID service_iface ->
(msg : service_reqType) ->
Process iface (service_iface msg) st st
Respond : ((msg : reqType) -> Process iface (iface msg) Ready Ready) ->
Process iface (Maybe reqType) st Sent
Spawn : Process service_iface () Ready Looping ->
Process iface (Maybe (MessagePID service_iface)) st st
Loop : Inf (Process iface a Ready Looping) ->
Process iface a Sent Looping
Action : IO a -> Process iface a st st
Pure : a -> Process iface a st st
(>>=) : Process iface a st1 st2 -> (a -> Process iface b st2 st3) ->
Process iface b st1 st3
public export
data Fuel = Dry | More (Lazy Fuel)
export partial
forever : Fuel
forever = More forever
export total
run : Fuel -> Process iface t in_state out_state -> IO (Maybe t)
run fuel (Request {service_iface} (MkMessage process) msg)
= do Just chan <- connect process
| _ => pure Nothing
ok <- unsafeSend chan msg
if ok then do Just x <- unsafeRecv (service_iface msg) chan
| Nothing => pure Nothing
pure (Just x)
else pure Nothing
run fuel (Respond {reqType} calc)
= do Just sender <- listen 1
| Nothing => pure (Just Nothing)
Just msg <- unsafeRecv reqType sender
| Nothing => pure (Just Nothing)
Just res <- run fuel (calc msg)
| Nothing => pure Nothing
unsafeSend sender res
pure (Just (Just msg))
run (More fuel) (Loop proc) = run fuel proc
run fuel (Spawn proc) = do Just pid <- spawn (do run fuel proc
pure ())
| Nothing => pure (Just Nothing)
pure (Just (Just (MkMessage pid)))
run fuel (Action act) = do res <- act
pure (Just res)
run fuel (Pure val) = pure (Just val)
run fuel (act >>= next) = do Just x <- run fuel act
| Nothing => pure Nothing
run fuel (next x)
run Dry _ = pure Nothing
public export
Service : (iface : reqType -> Type) -> Type -> Type
Service iface a = Process iface a Ready Looping
public export
Client : Type -> Type
Client a = Process NoRecv a Ready Ready
partial export
runProc : Process iface () in_state out_state -> IO ()
runProc proc = do run forever proc
pure ()
================================================
FILE: Chapter15/ProcessLoop.idr
================================================
import System.Concurrency.Channels
data Message = Add Nat Nat
data MessagePID = MkMessage PID
data Process : Type -> Type where
Request : MessagePID -> Message -> Process (Maybe Nat)
Respond : ((msg : Message) -> Process Nat) -> Process (Maybe Message)
Spawn : Process () -> Process (Maybe MessagePID)
Loop : Inf (Process a) -> Process a
Action : IO a -> Process a
Pure : a -> Process a
(>>=) : Process a -> (a -> Process b) -> Process b
public export
data Fuel = Dry | More (Lazy Fuel)
export partial
forever : Fuel
forever = More forever
total
run : Fuel -> Process t -> IO (Maybe t)
run fuel (Request (MkMessage process) msg)
= do Just chan <- connect process
| _ => pure (Just Nothing)
ok <- unsafeSend chan msg
if ok then do Just x <- unsafeRecv Nat chan
| Nothing => pure (Just Nothing)
pure (Just (Just x))
else pure (Just Nothing)
run fuel (Respond f)
= do Just sender <- listen 1
| Nothing => pure (Just Nothing)
Just msg <- unsafeRecv Message sender
| Nothing => pure (Just Nothing)
Just res <- run fuel (f msg)
| Nothing => pure Nothing
unsafeSend sender res
pure (Just (Just msg))
run (More fuel) (Loop proc) = run fuel proc
run fuel (Spawn proc) = do Just pid <- spawn (do run fuel proc
pure ())
| Nothing => pure Nothing
pure (Just (Just (MkMessage pid)))
run fuel (Action act) = do res <- act
pure (Just res)
run fuel (Pure val) = pure (Just val)
run fuel (act >>= next) = do Just x <- run fuel act
| Nothing => pure Nothing
run fuel (next x)
run Dry _ = pure Nothing
procAdder : Process ()
procAdder = do Respond (\msg => case msg of
Add x y => Pure (x + y))
Loop procAdder
procMain : Process ()
procMain = do Just adder_id <- Spawn procAdder
| Nothing => Action (putStrLn "Spawn failed")
Just answer <- Request adder_id (Add 2 3)
| Nothing => Action (putStrLn "Request failed")
Action (printLn answer)
partial
runProc : Process () -> IO ()
runProc proc = do run forever proc
pure ()
main : IO ()
main = runProc procMain
================================================
FILE: Chapter15/ProcessState.idr
================================================
import System.Concurrency.Channels
data Message = Add Nat Nat
data MessagePID = MkMessage PID
data ProcState = Ready | Sent | Looping
data Process : Type -> ProcState -> ProcState -> Type where
Request : MessagePID -> Message -> Process Nat st st
Respond : ((msg : Message) -> Process Nat Ready Ready) ->
Process (Maybe Message) st Sent
Spawn : Process () Ready Looping ->
Process (Maybe MessagePID) st st
Loop : Inf (Process a Ready Looping) ->
Process a Sent Looping
Action : IO a -> Process a st st
Pure : a -> Process a st st
(>>=) : Process a st1 st2 -> (a -> Process b st2 st3) ->
Process b st1 st3
public export
data Fuel = Dry | More (Lazy Fuel)
export partial
forever : Fuel
forever = More forever
total
run : Fuel -> Process t in_state out_state -> IO (Maybe t)
run fuel (Request (MkMessage process) msg)
= do Just chan <- connect process
| _ => pure Nothing
ok <- unsafeSend chan msg
if ok then do Just x <- unsafeRecv Nat chan
| Nothing => pure Nothing
pure (Just x)
else pure Nothing
run fuel (Respond f)
= do Just sender <- listen 1
| Nothing => pure (Just Nothing)
Just msg <- unsafeRecv Message sender
| Nothing => pure (Just Nothing)
Just res <- run fuel (f msg)
| Nothing => pure Nothing
unsafeSend sender res
pure (Just (Just msg))
run (More fuel) (Loop proc) = run fuel proc
run fuel (Spawn proc) = do Just pid <- spawn (do run fuel proc
pure ())
| Nothing => pure (Just Nothing)
pure (Just (Just (MkMessage pid)))
run fuel (Action act) = do res <- act
pure (Just res)
run fuel (Pure val) = pure (Just val)
run fuel (act >>= next) = do Just x <- run fuel act
| Nothing => pure Nothing
run fuel (next x)
run Dry _ = pure Nothing
Service : Type -> Type
Service a = Process a Ready Looping
Client : Type -> Type
Client a = Process a Ready Ready
{-
procAdder_bad1 : Process () Ready Looping
procAdder_bad1 = do Action (putStrLn "I'm out of the office today")
Loop procAdder_bad1
procAdder_bad2 : Process () Ready Looping
procAdder_bad2 = Loop procAdder_bad2
-}
procAdder : Service ()
procAdder = do Respond (\msg => case msg of
Add x y => Pure (x + y))
Loop procAdder
procMain : Client ()
procMain = do Just adder_id <- Spawn procAdder
| Nothing => Action (putStrLn "Spawn failed")
answer <- Request adder_id (Add 2 3)
Action (printLn answer)
partial
runProc : Process () in_state out_state -> IO ()
runProc proc = do run forever proc
pure ()
main : IO ()
main = runProc procMain
================================================
FILE: Chapter15/WordCount.idr
================================================
import ProcessLib
record WCData where
constructor MkWCData
wordCount : Nat
lineCount : Nat
doCount : (content : String) -> WCData
doCount content = let lcount = length (lines content)
wcount = length (words content) in
MkWCData lcount wcount
data WC = CountFile String
| GetData String
WCType : WC -> Type
WCType (CountFile x) = ()
WCType (GetData x) = Maybe WCData
countFile : List (String, WCData) -> String ->
Process WCType (List (String, WCData)) Sent Sent
countFile files fname =
do Right content <- Action (readFile fname)
| Left err => Pure files
let count = doCount content
Action (putStrLn ("Counting complete for " ++ fname))
Pure ((fname, doCount content) :: files)
total
wcService : (loaded : List (String, WCData)) -> Service WCType ()
wcService loaded
= do msg <- Respond (\msg => case msg of
CountFile fname => Pure ()
GetData fname =>
Pure (lookup fname loaded))
newLoaded <- case msg of
Just (CountFile fname) =>
countFile loaded fname
_ => Pure loaded
Loop (wcService newLoaded)
procMain : Client ()
procMain = do Just wc <- Spawn (wcService [])
| Nothing => Action (putStrLn "Spawn failed")
Action (putStrLn "Counting test.txt")
Request wc (CountFile "test.txt")
Action (putStrLn "Processing")
Just wcdata <- Request wc (GetData "test.txt")
| Nothing => Action (putStrLn "File error")
Action (putStrLn ("Words: " ++ show (wordCount wcdata)))
Action (putStrLn ("Lines: " ++ show (lineCount wcdata)))
partial
main : IO ()
main = runProc procMain
================================================
FILE: Chapter15/test.txt
================================================
test test
test
test test test
test
================================================
FILE: Chapter2/AveMain.idr
================================================
module Main
import Average
showAverage : String -> String
showAverage str = "The average word length is: " ++
show (average str) ++ "\n"
main : IO ()
main = repl "Enter a string: " showAverage
================================================
FILE: Chapter2/Average.idr
================================================
module Average
||| Calculate the average length of words in a string.
||| @str a string containing words separated by whitespace.
export
average : (str : String) -> Double
average str = let numWords = wordCount str
totalLength = sum (allLengths (words str)) in
cast totalLength / cast numWords
where
wordCount : String -> Nat
wordCount str = length (words str)
allLengths : List String -> List Nat
allLengths strs = map length strs
================================================
FILE: Chapter2/Double.idr
================================================
double : Int -> Int
double x = x + x
================================================
FILE: Chapter2/Exercises/ex_2.idr
================================================
{-
1. (String, String, String)
List String
((Char, String), Char)
-}
{- 2 -}
palindrome : String -> Bool
palindrome str = str == reverse str
{- 3 -}
palindrome_q3 : String -> Bool
palindrome_q3 str = let strL = toLower str in
strL == reverse strL
{- 4 -}
palindrome_q4 : String -> Bool
palindrome_q4 str = if length str > 10
then palindrome_q3 str
else False
{- 5 -}
palindrome_q5 : Nat -> String -> Bool
palindrome_q5 min str = if length str > min
then palindrome_q3 str
else False
{- 6 -}
counts : String -> (Nat, Nat)
counts str = (length (words str), length str)
{- 7 -}
top_ten : Ord a => List a -> List a
top_ten xs = take 10 (reverse (sort xs))
{- 8 -}
over_length : Nat -> List String -> Nat
over_length num xs = let lengths = map length xs in
length (filter (> num) lengths)
================================================
FILE: Chapter2/Exercises/ex_2_counts.idr
================================================
module Main
counts : String -> (Nat, Nat)
counts str = (length (words str), length str)
main : IO ()
main = repl "Enter a string: " show_counts
where
show_counts : String -> String
show_counts x = show (counts x) ++ "\n"
================================================
FILE: Chapter2/Exercises/ex_2_palindrome.idr
================================================
module Main
palindrome : String -> Bool
palindrome str = let strL = toLower str in
strL == reverse strL
main : IO ()
main = repl "Enter a string: " show_palindrome
where
show_palindrome : String -> String
show_palindrome x = show (palindrome x) ++ "\n"
================================================
FILE: Chapter2/Generic.idr
================================================
identityInt : Int -> Int
identityInt x = x
identityString : String -> String
identityString x = x
identityBool : Bool -> Bool
identityBool x = x
identity : ty -> ty
identity x = x
doubleNat : Nat -> Nat
doubleNat x = x * x
doubleInteger : Integer -> Integer
doubleInteger x = x * x
double : Num ty => ty -> ty
double x = x * x
================================================
FILE: Chapter2/HOF.idr
================================================
double : Num a => a -> a
double x = x * x
twice : (a -> a) -> a -> a
twice f x = f (f x)
Shape : Type
rotate : Shape -> Shape
quadruple : Num a => a -> a
quadruple = twice double
turn_around : Shape -> Shape
turn_around = twice rotate
================================================
FILE: Chapter2/Let_Where.idr
================================================
longer : String -> String -> Nat
longer word1 word2
= let len1 = length word1
len2 = length word2 in
if len1 > len2 then len1 else len2
pythagoras : Double -> Double -> Double
pythagoras x y = sqrt (square x + square y)
where
square : Double -> Double
square x = x * x
================================================
FILE: Chapter2/Partial.idr
================================================
add : Int -> Int -> Int
add x y = x + y
================================================
FILE: Chapter2/Reverse.idr
================================================
module Main
main : IO ()
main = repl "> " reverse
================================================
FILE: Chapter3/Exercises/ex_3_2.idr
================================================
import Data.Vect
{- 1 -}
my_length : List a -> Nat
my_length [] = 0
my_length (x :: xs) = 1 + my_length xs
{- 2 -}
my_reverse : List a -> List a
my_reverse [] = []
my_reverse (x :: xs) = my_reverse xs ++ [x]
{- 3 -}
my_map : (a -> b) -> List a -> List b
my_map f [] = []
my_map f (x :: xs) = f x :: my_map f xs
{- 4 -}
my_vect_map : (a -> b) -> Vect n a -> Vect n b
my_vect_map f [] = []
my_vect_map f (x :: xs) = f x :: my_vect_map f xs
================================================
FILE: Chapter3/Exercises/ex_3_3.idr
================================================
import Data.Vect
{- 1 -}
create_empties : Vect n (Vect 0 elem)
create_empties = replicate _ []
transpose_mat : Vect m (Vect n elem) -> Vect n (Vect m elem)
transpose_mat [] = create_empties
transpose_mat (x :: xs) = let xs_trans = transpose_mat xs in
zipWith (::) x xs_trans
{- 2 -}
addMatrix : Num a => Vect n (Vect m a) -> Vect n (Vect m a) -> Vect n (Vect m a)
addMatrix [] [] = []
addMatrix (x :: xs) (y :: ys) = zipWith (+) x y :: addMatrix xs ys
{- 3 -}
multVecs : Num a => (xs : Vect n a) -> (ys : Vect n a) -> a
multVecs xs ys = sum (zipWith (*) xs ys)
mkRow : Num a => (x : Vect n a) -> (ys_trans : Vect p (Vect n a)) -> Vect p a
mkRow x [] = []
mkRow x (y :: xs) = multVecs x y :: mkRow x xs
multMatrix_helper : Num a => (xs : Vect m (Vect n a)) -> (ys_trans : Vect p (Vect n a)) -> Vect m (Vect p a)
multMatrix_helper [] ys_trans = []
multMatrix_helper (x :: xs) ys_trans
= mkRow x ys_trans :: multMatrix_helper xs ys_trans
multMatrix : Num a => Vect m (Vect n a) -> Vect n (Vect p a) -> Vect m (Vect p a)
multMatrix xs ys = let ys_trans = transpose_mat ys in
multMatrix_helper xs ys_trans
================================================
FILE: Chapter3/IsEven.idr
================================================
isEven' : Nat -> Bool
isEven' Z = True
isEven' (S k) = not (isEven' k)
mutual
isEven : Nat -> Bool
isEven Z = True
isEven (S k) = isOdd k
isOdd : Nat -> Bool
isOdd Z = False
isOdd (S k) = isEven k
================================================
FILE: Chapter3/Matrix.idr
================================================
import Data.Vect
createEmpties : Vect n (Vect 0 elem)
createEmpties {n = Z} = []
createEmpties {n = (S k)} = [] :: createEmpties
transposeHelper : (x : Vect n elem) -> (xs_trans : Vect n (Vect k elem)) -> Vect n (Vect (S k) elem)
transposeHelper [] [] = []
transposeHelper (x :: xs) (y :: ys) = (x :: y) :: transposeHelper xs ys
transposeMat : Vect m (Vect n elem) -> Vect n (Vect m elem)
transposeMat [] = createEmpties
transposeMat (x :: xs) = let xsTrans = transposeMat xs in
transposeHelper x xsTrans
================================================
FILE: Chapter3/VecSort.idr
================================================
import Data.Vect
insert : Ord elem => (x : elem) -> (xsSorted : Vect k elem) -> Vect (S k) elem
insert x [] = [x]
insert x (y :: xs) = case x < y of
False => y :: insert x xs
True => x :: y :: xs
insSort : Ord elem => Vect n elem -> Vect n elem
insSort [] = []
insSort (x :: xs) = let xsSorted = insSort xs in
insert x xsSorted
================================================
FILE: Chapter3/Vectors.idr
================================================
import Data.Vect
fourInts : Vect 4 Int
fourInts = [0, 1, 2, 3]
sixInts : Vect 6 Int
sixInts = [4, 5, 6, 7, 8, 9]
tenInts : Vect 10 Int
tenInts = fourInts ++ sixInts
================================================
FILE: Chapter3/WordLength.idr
================================================
allLengths : List String -> List Nat
allLengths [] = []
allLengths (word :: words) = length word :: allLengths words
================================================
FILE: Chapter3/WordLength_vec.idr
================================================
import Data.Vect
total
allLengths : Vect len String -> Vect len Nat
allLengths [] = []
allLengths (word :: words) = length word :: allLengths words
================================================
FILE: Chapter3/XOR.idr
================================================
xor : Bool -> Bool -> Bool
xor False y = y
xor True y = not y
================================================
FILE: Chapter4/BSTree.idr
================================================
data BSTree : Type -> Type where
Empty : Ord elem => BSTree elem
Node : Ord elem => (left : BSTree elem) -> (val : elem) ->
(right : BSTree elem) -> BSTree elem
insert : elem -> BSTree elem -> BSTree elem
insert x Empty = Node Empty x Empty
insert x orig@(Node left val right)
= case compare x val of
LT => Node (insert x left) val right
EQ => orig
GT => Node left val (insert x right)
================================================
FILE: Chapter4/DataStore.idr
================================================
module Main
import Data.Vect
data DataStore : Type where
MkData : (size : Nat) -> (items : Vect size String) -> DataStore
size : DataStore -> Nat
size (MkData size' items') = size'
items : (store : DataStore) -> Vect (size store) String
items (MkData size' items') = items'
addToStore : DataStore -> String -> DataStore
addToStore (MkData size store) newitem = MkData _ (addToData store)
where
addToData : Vect oldsize String -> Vect (S oldsize) String
addToData [] = [newitem]
addToData (x :: xs) = x :: addToData xs
data Command = Add String
| Get Integer
| Quit
parseCommand : String -> String -> Maybe Command
parseCommand "add" str = Just (Add str)
parseCommand "get" val = case all isDigit (unpack val) of
False => Nothing
True => Just (Get (cast val))
parseCommand "quit" "" = Just Quit
parseCommand _ _ = Nothing
parse : (input : String) -> Maybe Command
parse input = case span (/= ' ') input of
(cmd, args) => parseCommand cmd (ltrim args)
getEntry : (pos : Integer) -> (store : DataStore) ->
Maybe (String, DataStore)
getEntry pos store
= let store_items = items store in
case integerToFin pos (size store) of
Nothing => Just ("Out of range\n", store)
Just id => Just (index id store_items ++ "\n", store)
processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store input
= case parse input of
Nothing => Just ("Invalid command\n", store)
Just (Add item) =>
Just ("ID " ++ show (size store) ++ "\n", addToStore store item)
Just (Get pos) => getEntry pos store
Just Quit => Nothing
main : IO ()
main = replWith (MkData _ []) "Command: " processInput
================================================
FILE: Chapter4/Direction.idr
================================================
data Direction = North | East | South | West
turnClockwise : Direction -> Direction
turnClockwise North = East
turnClockwise East = South
turnClockwise South = West
turnClockwise West = North
================================================
FILE: Chapter4/Exercises/ex_4_1.idr
================================================
{- Support code -}
data Shape = ||| A triangle, with its base length and height
Triangle Double Double
| ||| A rectangle, with its length and height
Rectangle Double Double
| ||| A circle, with its radius
Circle Double
area : Shape -> Double
area (Triangle base height) = 0.5 * base * height
area (Rectangle length height) = length * height
area (Circle radius) = pi * radius * radius
data Picture = Primitive Shape
| Combine Picture Picture
| Rotate Double Picture
| Translate Double Double Picture
testPic1 : Picture
testPic1 = Combine (Primitive (Triangle 2 3))
(Primitive (Triangle 2 4))
testPic2 : Picture
testPic2 = Combine (Primitive (Rectangle 1 3))
(Primitive (Circle 4))
data Tree elem = Empty
| Node (Tree elem) elem (Tree elem)
%name Tree tree, tree1
insert : Ord elem => elem -> Tree elem -> Tree elem
insert x Empty = Node Empty x Empty
insert x orig@(Node left val right)
= case compare x val of
LT => Node (insert x left) val right
EQ => orig
GT => Node left val (insert x right)
{- Answers -}
{- 1 -}
listToTree : Ord a => List a -> Tree a
listToTree [] = Empty
listToTree (x :: xs) = insert x (listToTree xs)
{- 2 -}
treeToList : Tree a -> List a
treeToList Empty = []
treeToList (Node left val right) = treeToList left ++ val :: treeToList right
{- 3 -}
data Expr = Val Int
| Add Expr Expr
| Sub Expr Expr
| Mult Expr Expr
{- 4 -}
evaluate : Expr -> Int
evaluate (Val x) = x
evaluate (Add x y) = evaluate x + evaluate y
evaluate (Sub x y) = evaluate x - evaluate y
evaluate (Mult x y) = evaluate x * evaluate y
{- 5 -}
maxMaybe : Ord a => Maybe a -> Maybe a -> Maybe a
maxMaybe Nothing Nothing = Nothing
maxMaybe Nothing (Just x) = Just x
maxMaybe (Just x) Nothing = Just x
maxMaybe (Just x) (Just y) = Just (max x y)
{- 6 -}
biggestTriangle : Picture -> Maybe Double
biggestTriangle (Primitive tri@(Triangle x y)) = Just (area tri)
biggestTriangle (Primitive _) = Nothing
biggestTriangle (Combine x y) = maxMaybe (biggestTriangle x) (biggestTriangle y)
biggestTriangle (Rotate x pic) = biggestTriangle pic
biggestTriangle (Translate x y pic) = biggestTriangle pic
================================================
FILE: Chapter4/Exercises/ex_4_2.idr
================================================
{- 1 -}
data PowerSource = Petrol | Pedal
data Vehicle : PowerSource -> Type where
Bicycle : Vehicle Pedal
Unicycle : Vehicle Pedal
Motorcycle : (fuel : Nat) -> Vehicle Petrol
Car : (fuel : Nat) -> Vehicle Petrol
Bus : (fuel : Nat) -> Vehicle Petrol
wheels : Vehicle power -> Nat
wheels Bicycle = 2
wheels Unicycle = 1
wheels (Motorcycle fuel) = 2
wheels (Car fuel) = 4
wheels (Bus fuel) = 4
refuel : Vehicle Petrol -> Vehicle Petrol
refuel (Car fuel) = Car 100
refuel (Bus fuel) = Bus 200
refuel (Motorcycle fuel) = Motorcycle 50
================================================
FILE: Chapter4/Exercises/ex_4_2_1.idr
================================================
{- 1 -}
data PowerSource = Petrol | Pedal
data Vehicle : PowerSource -> Type where
Bicycle : Vehicle Pedal
Unicycle : Vehicle Pedal
Motorcycle : (fuel : Nat) -> Vehicle Petrol
Car : (fuel : Nat) -> Vehicle Petrol
Bus : (fuel : Nat) -> Vehicle Petrol
wheels : Vehicle power -> Nat
wheels Bicycle = 2
wheels Unicycle = 1
wheels (Motorcycle fuel) = 2
wheels (Car fuel) = 4
wheels (Bus fuel) = 4
refuel : Vehicle Petrol -> Vehicle Petrol
refuel (Car fuel) = Car 100
refuel (Bus fuel) = Bus 200
refuel (Motorcycle fuel) = Motorcycle 50
================================================
FILE: Chapter4/Exercises/ex_4_2_2.idr
================================================
{- 2 -}
data PowerSource = Petrol | Pedal | Electric
data Vehicle : PowerSource -> Type where
Bicycle : Vehicle Pedal
Unicycle : Vehicle Pedal
Motorcycle : (fuel : Nat) -> Vehicle Petrol
Car : (fuel : Nat) -> Vehicle Petrol
Bus : (fuel : Nat) -> Vehicle Petrol
Tram : Vehicle Electric
wheels : Vehicle power -> Nat
wheels Bicycle = 2
wheels Unicycle = 1
wheels (Motorcycle fuel) = 2
wheels (Car fuel) = 4
wheels (Bus fuel) = 4
wheels Tram = 8
refuel : Vehicle Petrol -> Vehicle Petrol
refuel (Car fuel) = Car 100
refuel (Bus fuel) = Bus 200
refuel (Motorcycle fuel) = Motorcycle 50
================================================
FILE: Chapter4/Exercises/ex_4_2_3.idr
================================================
data Vect : Nat -> Type -> Type where
Nil : Vect Z a
(::) : (x : a) -> (xs : Vect k a) -> Vect (S k) a
%name Vect xs, ys, zs
{- 3 and 4-}
vectTake : (n : Nat) -> Vect (n + m) a -> Vect n a
vectTake Z xs = []
vectTake (S k) (x :: xs) = x :: vectTake k xs
================================================
FILE: Chapter4/Exercises/ex_4_2_5.idr
================================================
import Data.Vect
{- 5 -}
sumEntries : Num a => (pos : Integer) -> Vect n a -> Vect n a -> Maybe a
sumEntries {n} pos xs ys = case integerToFin pos n of
Nothing => Nothing
Just idx => Just (index idx xs + index idx ys)
================================================
FILE: Chapter4/Exercises/ex_4_3.idr
================================================
module Main
import Data.Vect
data DataStore : Type where
MkData : (size : Nat) -> (items : Vect size String) -> DataStore
size : DataStore -> Nat
size (MkData size' items') = size'
items : (store : DataStore) -> Vect (size store) String
items (MkData size' items') = items'
addToStore : DataStore -> String -> DataStore
addToStore (MkData size store) newitem = MkData _ (addToData store)
where
addToData : Vect oldsize String -> Vect (S oldsize) String
addToData [] = [newitem]
addToData (x :: xs) = x :: addToData xs
data Command = Add String
| Get Integer
| Size {- question 1 -}
| Search String {- question 2 -}
| Quit
parseCommand : List String -> Maybe Command
parseCommand ("add" :: rest) = Just (Add (unwords rest))
parseCommand ["get", val] = case all isDigit (unpack val) of
False => Nothing
True => Just (Get (cast val))
parseCommand ["quit"] = Just Quit
parseCommand ["size"] = Just Size {- question 1 -}
parseCommand ("search" :: rest) = Just (Search (unwords rest)) {- question 2 -}
parseCommand _ = Nothing
parse : (input : String) -> Maybe Command
parse input = parseCommand (words input)
getEntry : (pos : Integer) -> (store : DataStore) ->
Maybe (String, DataStore)
getEntry pos store
= let store_items = items store in
case integerToFin pos (size store) of
Nothing => Just ("Out of range\n", store)
Just id => Just (index id (items store) ++ "\n", store)
{- question 2/3 -}
searchString : Nat -> (items : Vect n String) -> (str : String) -> String
searchString idx [] str = ""
searchString idx (x :: xs) str
= let rest = searchString (idx + 1) xs str in
if isInfixOf str x
then show idx ++ ": " ++ x ++ "\n" ++ rest
else rest
processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store input
= case parse input of
Nothing => Just ("Invalid command\n", store)
Just (Add item) =>
Just ("ID " ++ show (size store) ++ "\n", addToStore store item)
Just (Get pos) => getEntry pos store
Just Size => Just (show (size store) ++ "\n", store) {- question 1 -}
Just (Search str) => Just (searchString 0 (items store) str, store) {- question 2 -}
Just Quit => Nothing
main : IO ()
main = replWith (MkData _ []) "Command: " processInput
================================================
FILE: Chapter4/Generic.idr
================================================
safeDivide : Double -> Double -> Maybe Double
safeDivide x y = if y == 0 then Nothing
else Just (x / y)
================================================
FILE: Chapter4/Picture.idr
================================================
data Shape = ||| A triangle, with its base length and height
Triangle Double Double
| ||| A rectangle, with its length and height
Rectangle Double Double
| ||| A circle, with its radius
Circle Double
area : Shape -> Double
area (Triangle base height) = 0.5 * base * height
area (Rectangle length height) = length * height
area (Circle radius) = pi * radius * radius
data Picture = Primitive Shape
| Combine Picture Picture
| Rotate Double Picture
| Translate Double Double Picture
rectangle : Picture
rectangle = Primitive (Rectangle 20 10)
circle : Picture
circle = Primitive (Circle 5)
triangle : Picture
triangle = Primitive (Triangle 10 10)
testPicture : Picture
testPicture = Combine (Translate 5 5 rectangle)
(Combine (Translate 35 5 circle)
(Translate 15 25 triangle))
pictureArea : Picture -> Double
pictureArea (Primitive shape) = area shape
pictureArea (Combine pic pic1) = pictureArea pic + pictureArea pic1
pictureArea (Rotate x pic) = pictureArea pic
pictureArea (Translate x y pic) = pictureArea pic
================================================
FILE: Chapter4/Shape.idr
================================================
data Shape = ||| A triangle, with its base length and height
Triangle Double Double
| ||| A rectangle, with its length and height
Rectangle Double Double
| ||| A circle, with its radius
Circle Double
area : Shape -> Double
area (Triangle base height) = 0.5 * base * height
area (Rectangle length height) = length * height
area (Circle radius) = pi * radius * radius
================================================
FILE: Chapter4/SumInputs.idr
================================================
sumInputs : Integer -> String -> Maybe (String, Integer)
sumInputs tot inp
= let val = cast inp in
if val < 0
then Nothing
else let newVal = tot + val in
Just ("Subtotal: " ++ show newVal ++ "\n", newVal)
main : IO ()
main = replWith 0 "Value: " sumInputs
================================================
FILE: Chapter4/Tree.idr
================================================
data Tree elem = Empty
| Node (Tree elem) elem (Tree elem)
%name Tree tree, tree1
insert : Ord elem => elem -> Tree elem -> Tree elem
insert x Empty = Node Empty x Empty
insert x orig@(Node left val right)
= case compare x val of
LT => Node (insert x left) val right
EQ => orig
GT => Node left val (insert x right)
================================================
FILE: Chapter4/TryIndex.idr
================================================
import Data.Vect
tryIndex : Integer -> Vect n a -> Maybe a
tryIndex {n} i xs = case integerToFin i n of
Nothing => Nothing
Just idx => Just (index idx xs)
================================================
FILE: Chapter4/Vect.idr
================================================
data Vect : Nat -> Type -> Type where
Nil : Vect Z a
(::) : (x : a) -> (xs : Vect k a) -> Vect (S k) a
%name Vect xs, ys, zs
append : Vect n elem -> Vect m elem -> Vect (n + m) elem
append [] ys = ys
append (x :: xs) ys = x :: append xs ys
zip : Vect n a -> Vect n b -> Vect n (a, b)
zip [] [] = []
zip (x :: xs) (y :: ys) = (x, y) :: zip xs ys
================================================
FILE: Chapter4/Vehicle.idr
================================================
data PowerSource = Petrol | Pedal
data Vehicle : PowerSource -> Type where
Bicycle : Vehicle Pedal
Car : (fuel : Nat) -> Vehicle Petrol
Bus : (fuel : Nat) -> Vehicle Petrol
wheels : Vehicle power -> Nat
wheels Bicycle = 2
wheels (Car fuel) = 4
wheels (Bus fuel) = 4
refuel : Vehicle Petrol -> Vehicle Petrol
refuel (Car fuel) = Car 100
refuel (Bus fuel) = Bus 200
refuel Bicycle impossible
================================================
FILE: Chapter5/DepPairs.idr
================================================
import Data.Vect
anyVect : (n ** Vect n String)
anyVect = (3 ** ["Rod", "Jane", "Freddy"])
readVect : IO (len ** Vect len String)
readVect = do x <- getLine
if (x == "")
then pure (_ ** [])
else do (_ ** xs) <- readVect
pure (_ ** x :: xs)
zipInputs : IO ()
zipInputs = do putStrLn "Enter first vector (blank line to end):"
(len1 ** vec1) <- readVect
putStrLn "Enter second vector (blank line to end):"
(len2 ** vec2) <- readVect
case exactLength len1 vec2 of
Nothing => putStrLn "Vectors are different lengths"
Just vec2' => printLn (zip vec1 vec2')
================================================
FILE: Chapter5/Do.idr
================================================
printTwoThings : IO ()
printTwoThings = do putStrLn "Hello"
putStrLn "World"
printInput : IO ()
printInput = do x <- getLine
putStrLn x
printLength : IO ()
printLength = do putStr "Input string: "
input <- getLine
let len = length input
putStrLn (show len)
================================================
FILE: Chapter5/Exercises/ex_5_1.idr
================================================
{- 1 -}
printLonger : IO ()
printLonger = do putStr "First string: "
str1 <- getLine
putStr "Second string: "
str2 <- getLine
if length str1 > length str2
then putStrLn (show (length str1))
else putStrLn (show (length str2))
{- 2 -}
printLonger' : IO ()
printLonger' = putStr "First string: " >>= \_ =>
getLine >>= \str1 =>
putStr "Second string: " >>= \_ =>
getLine >>= \str2 =>
if length str1 > length str2
then putStrLn (show (length str1))
else putStrLn (show (length str2))
================================================
FILE: Chapter5/Exercises/ex_5_2_1.idr
================================================
import System
{- 1 -}
readNumber : IO (Maybe Nat)
readNumber = do
input <- getLine
if all isDigit (unpack input)
then pure (Just (cast input))
else pure Nothing
guess : (answer : Nat) -> IO ()
guess answer = do
putStr ("Guess a number between 1 and 100: ")
isNum <- readNumber
case isNum of
Nothing => do putStrLn "Invalid input"
guess answer
Just userguess => if userguess < answer
then do putStrLn "Too low"
guess answer
else if userguess > answer
then do putStrLn "Too high"
guess answer
else putStrLn "Well done!"
{- 2 -}
main : IO ()
main = do t <- time
guess (cast (t `mod` 101))
================================================
FILE: Chapter5/Exercises/ex_5_2_3.idr
================================================
import System
{- 3 -}
readNumber : IO (Maybe Nat)
readNumber = do
input <- getLine
if all isDigit (unpack input)
then pure (Just (cast input))
else pure Nothing
guess : (target : Nat) -> (guesses : Nat) -> IO ()
guess target guesses = do
putStrLn (show guesses ++ " guesses so far")
putStr ("Guess a number between 1 and 100: ")
isNum <- readNumber
case isNum of
Nothing => do putStrLn "Invalid input"
guess target guesses
Just userguess => if userguess < target
then do putStrLn "Too low"
guess target (guesses + 1)
else if userguess > target
then do putStrLn "Too high"
guess target (guesses + 1)
else putStrLn "Well done!"
main : IO ()
main = do t <- time
guess (cast (t `mod` 101)) 0
================================================
FILE: Chapter5/Exercises/ex_5_2_4.idr
================================================
{- 4 -}
my_repl : (prompt : String) ->
(fn : String -> String) -> IO ()
my_repl prompt fn
= do putStr prompt
x <- getLine
putStr (fn x)
my_repl prompt fn
my_replWith : (state : a) -> (prompt : String) ->
(fn : a -> String -> Maybe (String, a)) -> IO ()
my_replWith acc prompt fn
= do putStr prompt
x <- getLine
case fn acc x of
Just (out, acc') => do putStr out
my_replWith acc' prompt fn
Nothing => pure ()
================================================
FILE: Chapter5/Exercises/ex_5_3.idr
================================================
import Data.Vect
{- 1 -}
readToBlank : IO (List String)
readToBlank = do x <- getLine
case x of
"" => pure []
_ => do rest <- readToBlank
pure (x :: rest)
{- 2 -}
readAndSave : IO ()
readAndSave = do lines <- readToBlank
putStr "Filename: "
f <- getLine
Right () <- writeFile f (unlines lines)
| Left err => putStrLn (show err)
pure ()
{- 3 -}
readVectFile : (filename : String) -> IO (n ** Vect n String)
readVectFile filename = do Right h <- openFile filename Read
| Left err => pure (_ ** [])
Right contents <- readContents h
| Left err => pure (_ ** [])
closeFile h
pure contents
where readContents : File -> IO (Either FileError (n ** Vect n String))
readContents h = do eof <- fEOF h
if eof then pure (Right (_ ** [])) else do
Right str <- fGetLine h
| Left err => pure (Left err)
Right (_ ** rest) <- readContents h
| Left err => pure (Left err)
pure (Right (_ ** str :: rest))
================================================
FILE: Chapter5/Hello.idr
================================================
module Main
main : IO ()
main = do
putStr "Enter your name: "
x <- getLine
putStrLn ("Hello " ++ x ++ "!")
================================================
FILE: Chapter5/Loops.idr
================================================
module Main
import System
countdown : (secs : Nat) -> IO ()
countdown Z = putStrLn "Lift off!"
countdown (S secs) = do putStrLn (show (S secs))
usleep 1000000
countdown secs
readNumber : IO (Maybe Nat)
readNumber = do
input <- getLine
if all isDigit (unpack input)
then pure (Just (cast input))
else pure Nothing
countdowns : IO ()
countdowns = do putStr "Enter starting number: "
Just startNum <- readNumber
| Nothing => do putStrLn "Invalid input"
countdowns
countdown startNum
putStr "Another (y/n)? "
yn <- getLine
if yn == "y" then countdowns
else pure ()
================================================
FILE: Chapter5/PrintLength.idr
================================================
printLength : IO ()
printLength = putStr "Input string: " >>= \_ =>
getLine >>= \input =>
let len = length input in
putStrLn (show len)
================================================
FILE: Chapter5/ReadNum.idr
================================================
readNumber : IO (Maybe Nat)
readNumber = do
input <- getLine
if all isDigit (unpack input)
then pure (Just (cast input))
else pure Nothing
readNumbers_v1 : IO (Maybe (Nat, Nat))
readNumbers_v1 =
do num1 <- readNumber
case num1 of
Nothing => pure Nothing
Just num1_ok =>
do num2 <- readNumber
case num2 of
Nothing => pure Nothing
Just num2_ok => pure (Just (num1_ok, num2_ok))
readPair : IO (String, String)
readPair = do str1 <- getLine
str2 <- getLine
pure (str1, str2)
readNumbers_v2 : IO (Maybe (Nat, Nat))
readNumbers_v2 =
do Just num1_ok <- readNumber
Just num2_ok <- readNumber
pure (Just (num1_ok, num2_ok))
readNumbers : IO (Maybe (Nat, Nat))
readNumbers =
do Just num1_ok <- readNumber | Nothing => pure Nothing
Just num2_ok <- readNumber | Nothing => pure Nothing
pure (Just (num1_ok, num2_ok))
================================================
FILE: Chapter5/ReadVect.idr
================================================
import Data.Vect
readVectLen : (len : Nat) -> IO (Vect len String)
readVectLen Z = pure []
readVectLen (S k) = do x <- getLine
xs <- readVectLen k
pure (x :: xs)
data VectUnknown : Type -> Type where
MkVect : (len : Nat) -> Vect len a -> VectUnknown a
readVect : IO (VectUnknown String)
readVect = do x <- getLine
if (x == "")
then pure (MkVect _ [])
else do MkVect _ xs <- readVect
pure (MkVect _ (x :: xs))
printVect : Show a => VectUnknown a -> IO ()
printVect (MkVect len xs)
= putStrLn (show xs ++ " (length " ++ show len ++ ")")
================================================
FILE: Chapter6/Adder.idr
================================================
AdderType : (numargs : Nat) -> Type -> Type
AdderType Z numType = numType
AdderType (S k) numType = (next : numType) -> AdderType k numType
adder : Num numType =>
(numargs : Nat) -> numType -> AdderType numargs numType
adder Z acc = acc
adder (S k) acc = \next => adder k (next + acc)
================================================
FILE: Chapter6/DataStore.idr
================================================
module Main
import Data.Vect
infixr 5 .+.
data Schema = SString | SInt | (.+.) Schema Schema
SchemaType : Schema -> Type
SchemaType SString = String
SchemaType SInt = Int
SchemaType (x .+. y) = (SchemaType x, SchemaType y)
record DataStore where
constructor MkData
schema : Schema
size : Nat
items : Vect size (SchemaType schema)
addToStore : (store : DataStore) -> SchemaType (schema store) -> DataStore
addToStore (MkData schema size store) newitem = MkData schema _ (addToData store)
where
addToData : Vect oldsize (SchemaType schema) -> Vect (S oldsize) (SchemaType schema)
addToData [] = [newitem]
addToData (x :: xs) = x :: addToData xs
setSchema : (store : DataStore) -> Schema -> Maybe DataStore
setSchema store schema = case size store of
Z => Just (MkData schema _ [])
S k => Nothing
data Command : Schema -> Type where
SetSchema : Schema -> Command schema
Add : SchemaType schema -> Command schema
Get : Integer -> Command schema
Quit : Command schema
parsePrefix : (schema : Schema) -> String -> Maybe (SchemaType schema, String)
parsePrefix SString input = getQuoted (unpack input)
where
getQuoted : List Char -> Maybe (String, String)
getQuoted ('"' :: xs)
= case span (/= '"') xs of
(quoted, '"' :: rest) => Just (pack quoted, ltrim (pack rest))
_ => Nothing
getQuoted _ = Nothing
parsePrefix SInt input = case span isDigit input of
("", rest) => Nothing
(num, rest) => Just (cast num, ltrim rest)
parsePrefix (schemal .+. schemar) input
= case parsePrefix schemal input of
Nothing => Nothing
Just (l_val, input') =>
case parsePrefix schemar input' of
Nothing => Nothing
Just (r_val, input'') => Just ((l_val, r_val), input'')
parseBySchema : (schema : Schema) -> String -> Maybe (SchemaType schema)
parseBySchema schema x = case parsePrefix schema x of
Nothing => Nothing
Just (res, "") => Just res
Just _ => Nothing
parseSchema : List String -> Maybe Schema
parseSchema ("String" :: xs)
= case xs of
[] => Just SString
_ => case parseSchema xs of
Nothing => Nothing
Just xs_sch => Just (SString .+. xs_sch)
parseSchema ("Int" :: xs)
= case xs of
[] => Just SInt
_ => case parseSchema xs of
Nothing => Nothing
Just xs_sch => Just (SInt .+. xs_sch)
parseSchema _ = Nothing
parseCommand : (schema : Schema) -> String -> String -> Maybe (Command schema)
parseCommand schema "add" rest = case parseBySchema schema rest of
Nothing => Nothing
Just restok => Just (Add restok)
parseCommand schema "get" val = case all isDigit (unpack val) of
False => Nothing
True => Just (Get (cast val))
parseCommand schema "quit" "" = Just Quit
parseCommand schema "schema" rest
= case parseSchema (words rest) of
Nothing => Nothing
Just schemaok => Just (SetSchema schemaok)
parseCommand _ _ _ = Nothing
parse : (schema : Schema) -> (input : String) -> Maybe (Command schema)
parse schema input = case span (/= ' ') input of
(cmd, args) => parseCommand schema cmd (ltrim args)
display : SchemaType schema -> String
display {schema = SString} item = show item
display {schema = SInt} item = show item
display {schema = (y .+. z)} (iteml, itemr) = display iteml ++ ", " ++
display itemr
getEntry : (pos : Integer) -> (store : DataStore) ->
Maybe (String, DataStore)
getEntry pos store
= let store_items = items store in
case integerToFin pos (size store) of
Nothing => Just ("Out of range\n", store)
Just id => Just (display (index id (items store)) ++ "\n", store)
processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store input
= case parse (schema store) input of
Nothing => Just ("Invalid command\n", store)
Just (Add item) =>
Just ("ID " ++ show (size store) ++ "\n", addToStore store item)
Just (SetSchema schema') =>
case setSchema store schema' of
Nothing => Just ("Can't update schema when entries in store\n", store)
Just store' => Just ("OK\n", store')
Just (Get pos) => getEntry pos store
Just Quit => Nothing
main : IO ()
main = replWith (MkData (SString .+. SString .+. SInt) _ []) "Command: " processInput
================================================
FILE: Chapter6/DataStoreHoles.idr
================================================
module Main
import Data.Vect
infixr 5 .+.
data Schema = SString | SInt | (.+.) Schema Schema
SchemaType : Schema -> Type
SchemaType SString = String
SchemaType SInt = Int
SchemaType (x .+. y) = (SchemaType x, SchemaType y)
record DataStore where
constructor MkData
schema : Schema
size : Nat
items : Vect size (SchemaType schema)
addToStore : (d : DataStore) -> SchemaType (schema d) -> DataStore
addToStore (MkData schema size store) newitem = MkData schema _ (addToData store)
where
addToData : Vect oldsize (SchemaType schema) -> Vect (S oldsize) (SchemaType schema)
addToData [] = [newitem]
addToData (x :: xs) = x :: addToData xs
data Command : Schema -> Type where
Add : SchemaType schema -> Command schema
Get : Integer -> Command schema
Quit : Command schema
parseCommand : String -> String -> Maybe (Command schema)
parseCommand "add" rest = Just (Add (?parseBySchema rest))
parseCommand "get" val = case all isDigit (unpack val) of
False => Nothing
True => Just (Get (cast val))
parseCommand "quit" "" = Just Quit
parseCommand _ _ = Nothing
parse : (schema : Schema) -> (input : String) -> Maybe (Command schema)
parse schema input = case span (/= ' ') input of
(cmd, args) => parseCommand cmd (ltrim args)
getEntry : (pos : Integer) -> (store : DataStore) ->
Maybe (String, DataStore)
getEntry pos store
= let store_items = items store in
case integerToFin pos (size store) of
Nothing => Just ("Out of range\n", store)
Just id => Just (?display (index id (items store)) ++ "\n", store)
processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store input
= case parse (schema store) input of
Nothing => Just ("Invalid command\n", store)
Just (Add item) =>
Just ("ID " ++ show (size store) ++ "\n", addToStore store item)
Just (Get pos) => getEntry pos store
Just Quit => Nothing
main : IO ()
main = replWith (MkData SString _ []) "Command: " processInput
================================================
FILE: Chapter6/Exercises/ex_6_2_1.idr
================================================
import Data.Vect
{- 1 -}
Matrix : Nat -> Nat -> Type
Matrix n m = Vect n (Vect m Double)
testMatrix : Matrix 2 3
testMatrix = [[0, 0, 0], [0, 0, 0]]
================================================
FILE: Chapter6/Exercises/ex_6_2_2.idr
================================================
data Format = Number Format
| Str Format
| Lit String Format
| Ch Format
| Dbl Format
| End
PrintfType : Format -> Type
PrintfType (Number fmt) = (i : Int) -> PrintfType fmt
PrintfType (Str fmt) = (str : String) -> PrintfType fmt
PrintfType (Lit str fmt) = PrintfType fmt
PrintfType (Ch fmt) = (c : Char) -> PrintfType fmt
PrintfType (Dbl fmt) = (d : Double) -> PrintfType fmt
PrintfType End = String
printfFmt : (fmt : Format) -> (acc : String) -> PrintfType fmt
printfFmt (Number fmt) acc = \i => printfFmt fmt (acc ++ show i)
printfFmt (Str fmt) acc = \str => printfFmt fmt (acc ++ str)
printfFmt (Ch fmt) acc = \c => printfFmt fmt (acc ++ show c)
printfFmt (Dbl fmt) acc = \d => printfFmt fmt (acc ++ show d)
printfFmt (Lit lit fmt) acc = printfFmt fmt (acc ++ lit)
printfFmt End acc = acc
toFormat : (xs : List Char) -> Format
toFormat [] = End
toFormat ('%' :: 'd' :: chars) = Number (toFormat chars)
toFormat ('%' :: 's' :: chars) = Str (toFormat chars)
toFormat ('%' :: 'c' :: chars) = Ch (toFormat chars)
toFormat ('%' :: 'f' :: chars) = Dbl (toFormat chars)
toFormat ('%' :: chars) = Lit "%" (toFormat chars)
toFormat (c :: chars) = case toFormat chars of
Lit lit chars' => Lit (strCons c lit) chars'
fmt => Lit (strCons c "") fmt
printf : (fmt : String) -> PrintfType (toFormat (unpack fmt))
printf fmt = printfFmt _ ""
================================================
FILE: Chapter6/Exercises/ex_6_2_3.idr
================================================
TupleVect : Nat -> Type -> Type
TupleVect Z ty = ()
TupleVect (S k) ty = (ty, TupleVect k ty)
test : TupleVect 4 Nat
test = (1,2,3,4,())
================================================
FILE: Chapter6/Exercises/ex_6_3_1.idr
================================================
module Main
import Data.Vect
infixr 5 .+.
data Schema = SString | SInt | SChar | (.+.) Schema Schema
SchemaType : Schema -> Type
SchemaType SString = String
SchemaType SInt = Int
SchemaType SChar = Char
SchemaType (x .+. y) = (SchemaType x, SchemaType y)
record DataStore where
constructor MkData
schema : Schema
size : Nat
items : Vect size (SchemaType schema)
addToStore : (store : DataStore) -> SchemaType (schema store) -> DataStore
addToStore (MkData schema size store) newitem = MkData schema _ (addToData store)
where
addToData : Vect oldsize (SchemaType schema) -> Vect (S oldsize) (SchemaType schema)
addToData [] = [newitem]
addToData (x :: xs) = x :: addToData xs
setSchema : (store : DataStore) -> Schema -> Maybe DataStore
setSchema store schema = case size store of
Z => Just (MkData schema _ [])
S k => Nothing
data Command : Schema -> Type where
SetSchema : Schema -> Command schema
Add : SchemaType schema -> Command schema
Get : Integer -> Command schema
Quit : Command schema
parsePrefix : (schema : Schema) -> String -> Maybe (SchemaType schema, String)
parsePrefix SString input = getQuoted (unpack input)
where
getQuoted : List Char -> Maybe (String, String)
getQuoted ('"' :: xs)
= case span (/= '"') xs of
(quoted, '"' :: rest) => Just (pack quoted, ltrim (pack rest))
_ => Nothing
getQuoted _ = Nothing
parsePrefix SInt input = case span isDigit input of
("", rest) => Nothing
(num, rest) => Just (cast num, ltrim rest)
parsePrefix SChar input = case unpack input of
(c :: cs) => Just (c, ltrim (pack cs))
[] => Nothing
parsePrefix (schemal .+. schemar) input
= case parsePrefix schemal input of
Nothing => Nothing
Just (l_val, input') =>
case parsePrefix schemar input' of
Nothing => Nothing
Just (r_val, input'') => Just ((l_val, r_val), input'')
parseBySchema : (schema : Schema) -> String -> Maybe (SchemaType schema)
parseBySchema schema x = case parsePrefix schema x of
Nothing => Nothing
Just (res, "") => Just res
Just _ => Nothing
parseSchema : List String -> Maybe Schema
parseSchema ("String" :: xs)
= case xs of
[] => Just SString
_ => case parseSchema xs of
Nothing => Nothing
Just xs_sch => Just (SString .+. xs_sch)
parseSchema ("Int" :: xs)
= case xs of
[] => Just SInt
_ => case parseSchema xs of
Nothing => Nothing
Just xs_sch => Just (SInt .+. xs_sch)
parseSchema ("Char" :: xs)
= case xs of
[] => Just SInt
_ => case parseSchema xs of
Nothing => Nothing
Just xs_sch => Just (SChar .+. xs_sch)
parseSchema _ = Nothing
parseCommand : (schema : Schema) -> String -> String -> Maybe (Command schema)
parseCommand schema "add" rest = case parseBySchema schema rest of
Nothing => Nothing
Just restok => Just (Add restok)
parseCommand schema "get" val = case all isDigit (unpack val) of
False => Nothing
True => Just (Get (cast val))
parseCommand schema "quit" "" = Just Quit
parseCommand schema "schema" rest
= case parseSchema (words rest) of
Nothing => Nothing
Just schemaok => Just (SetSchema schemaok)
parseCommand _ _ _ = Nothing
parse : (schema : Schema) -> (input : String) -> Maybe (Command schema)
parse schema input = case span (/= ' ') input of
(cmd, args) => parseCommand schema cmd (ltrim args)
display : SchemaType schema -> String
display {schema = SString} item = show item
display {schema = SInt} item = show item
display {schema = SChar} item = show item
display {schema = (y .+. z)} (iteml, itemr) = display iteml ++ ", " ++
display itemr
getEntry : (pos : Integer) -> (store : DataStore) ->
Maybe (String, DataStore)
getEntry pos store
= let store_items = items store in
case integerToFin pos (size store) of
Nothing => Just ("Out of range\n", store)
Just id => Just (display (index id (items store)) ++ "\n", store)
processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store input
= case parse (schema store) input of
Nothing => Just ("Invalid command\n", store)
Just (Add item) =>
Just ("ID " ++ show (size store) ++ "\n", addToStore store item)
Just (SetSchema schema') =>
case setSchema store schema' of
Nothing => Just ("Can't update schema when entries in store\n", store)
Just store' => Just ("OK\n", store')
Just (Get pos) => getEntry pos store
Just Quit => Nothing
main : IO ()
main = replWith (MkData (SString .+. SString .+. SInt) _ []) "Command: " processInput
================================================
FILE: Chapter6/Exercises/ex_6_3_2.idr
================================================
module Main
import Data.Vect
infixr 5 .+.
data Schema = SString | SInt | SChar | (.+.) Schema Schema
SchemaType : Schema -> Type
SchemaType SString = String
SchemaType SInt = Int
SchemaType SChar = Char
SchemaType (x .+. y) = (SchemaType x, SchemaType y)
record DataStore where
constructor MkData
schema : Schema
size : Nat
items : Vect size (SchemaType schema)
addToStore : (store : DataStore) -> SchemaType (schema store) -> DataStore
addToStore (MkData schema size store) newitem = MkData schema _ (addToData store)
where
addToData : Vect oldsize (SchemaType schema) -> Vect (S oldsize) (SchemaType schema)
addToData [] = [newitem]
addToData (x :: xs) = x :: addToData xs
setSchema : (store : DataStore) -> Schema -> Maybe DataStore
setSchema store schema = case size store of
Z => Just (MkData schema _ [])
S k => Nothing
data Command : Schema -> Type where
SetSchema : Schema -> Command schema
Add : SchemaType schema -> Command schema
Get : Maybe Integer -> Command schema
Quit : Command schema
parsePrefix : (schema : Schema) -> String -> Maybe (SchemaType schema, String)
parsePrefix SString input = getQuoted (unpack input)
where
getQuoted : List Char -> Maybe (String, String)
getQuoted ('"' :: xs)
= case span (/= '"') xs of
(quoted, '"' :: rest) => Just (pack quoted, ltrim (pack rest))
_ => Nothing
getQuoted _ = Nothing
parsePrefix SInt input = case span isDigit input of
("", rest) => Nothing
(num, rest) => Just (cast num, ltrim rest)
parsePrefix SChar input = case unpack input of
(c :: cs) => Just (c, ltrim (pack cs))
[] => Nothing
parsePrefix (schemal .+. schemar) input
= case parsePrefix schemal input of
Nothing => Nothing
Just (l_val, input') =>
case parsePrefix schemar input' of
Nothing => Nothing
Just (r_val, input'') => Just ((l_val, r_val), input'')
parseBySchema : (schema : Schema) -> String -> Maybe (SchemaType schema)
parseBySchema schema x = case parsePrefix schema x of
Nothing => Nothing
Just (res, "") => Just res
Just _ => Nothing
parseSchema : List String -> Maybe Schema
parseSchema ("String" :: xs)
= case xs of
[] => Just SString
_ => case parseSchema xs of
Nothing => Nothing
Just xs_sch => Just (SString .+. xs_sch)
parseSchema ("Int" :: xs)
= case xs of
[] => Just SInt
_ => case parseSchema xs of
Nothing => Nothing
Just xs_sch => Just (SInt .+. xs_sch)
parseSchema ("Char" :: xs)
= case xs of
[] => Just SInt
_ => case parseSchema xs of
Nothing => Nothing
Just xs_sch => Just (SChar .+. xs_sch)
parseSchema _ = Nothing
parseCommand : (schema : Schema) -> String -> String -> Maybe (Command schema)
parseCommand schema "add" rest = case parseBySchema schema rest of
Nothing => Nothing
Just restok => Just (Add restok)
parseCommand schema "get" "" = Just (Get Nothing)
parseCommand schema "get" val = case all isDigit (unpack val) of
False => Nothing
True => Just (Get (Just (cast val)))
parseCommand schema "quit" "" = Just Quit
parseCommand schema "schema" rest
= case parseSchema (words rest) of
Nothing => Nothing
Just schemaok => Just (SetSchema schemaok)
parseCommand _ _ _ = Nothing
parse : (schema : Schema) -> (input : String) -> Maybe (Command schema)
parse schema input = case span (/= ' ') input of
(cmd, args) => parseCommand schema cmd (trim args)
display : SchemaType schema -> String
display {schema = SString} item = show item
display {schema = SInt} item = show item
display {schema = SChar} item = show item
display {schema = (y .+. z)} (iteml, itemr) = display iteml ++ ", " ++
display itemr
getEntry : (pos : Integer) -> (store : DataStore) ->
Maybe (String, DataStore)
getEntry pos store
= let store_items = items store in
case integerToFin pos (size store) of
Nothing => Just ("Out of range\n", store)
Just id => Just (display (index id (items store)) ++ "\n", store)
showAll : Nat -> Vect size (SchemaType schema) -> String
showAll idx [] = ""
showAll idx (x :: xs) = show idx ++ ": " ++ display x ++ "\n" ++
showAll (idx + 1) xs
processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store input
= case parse (schema store) input of
Nothing => Just ("Invalid command\n", store)
Just (Add item) =>
Just ("ID " ++ show (size store) ++ "\n", addToStore store item)
Just (SetSchema schema') =>
case setSchema store schema' of
Nothing => Just ("Can't update schema when entries in store\n", store)
Just store' => Just ("OK\n", store')
Just (Get (Just pos)) => getEntry pos store
Just (Get Nothing) => Just (showAll 0 (items store) ++ "\n", store)
Just Quit => Nothing
main : IO ()
main = replWith (MkData (SString .+. SString .+. SInt) _ []) "Command: " processInput
================================================
FILE: Chapter6/Exercises/ex_6_3_3.idr
================================================
module Main
import Data.Vect
infixr 5 .+.
data Schema = SString | SInt | SChar | (.+.) Schema Schema
SchemaType : Schema -> Type
SchemaType SString = String
SchemaType SInt = Int
SchemaType SChar = Char
SchemaType (x .+. y) = (SchemaType x, SchemaType y)
record DataStore where
constructor MkData
schema : Schema
size : Nat
items : Vect size (SchemaType schema)
addToStore : (store : DataStore) -> SchemaType (schema store) -> DataStore
addToStore (MkData schema size store) newitem = MkData schema _ (addToData store)
where
addToData : Vect oldsize (SchemaType schema) -> Vect (S oldsize) (SchemaType schema)
addToData [] = [newitem]
addToData (x :: xs) = x :: addToData xs
setSchema : (store : DataStore) -> Schema -> Maybe DataStore
setSchema store schema = case size store of
Z => Just (MkData schema _ [])
S k => Nothing
data Command : Schema -> Type where
SetSchema : Schema -> Command schema
Add : SchemaType schema -> Command schema
Get : Maybe Integer -> Command schema
Quit : Command schema
parsePrefix : (schema : Schema) -> String -> Maybe (SchemaType schema, String)
parsePrefix SString input = getQuoted (unpack input)
where
getQuoted : List Char -> Maybe (String, String)
getQuoted ('"' :: xs)
= case span (/= '"') xs of
(quoted, '"' :: rest) => Just (pack quoted, ltrim (pack rest))
_ => Nothing
getQuoted _ = Nothing
parsePrefix SInt input = case span isDigit input of
("", rest) => Nothing
(num, rest) => Just (cast num, ltrim rest)
parsePrefix SChar input = case unpack input of
(c :: cs) => Just (c, ltrim (pack cs))
[] => Nothing
parsePrefix (schemal .+. schemar) input
= do (l_val, input') <- parsePrefix schemal input
(r_val, input'') <- parsePrefix schemar input'
Just ((l_val, r_val), input'')
parseBySchema : (schema : Schema) -> String -> Maybe (SchemaType schema)
parseBySchema schema x = case parsePrefix schema x of
Nothing => Nothing
Just (res, "") => Just res
Just _ => Nothing
parseSchema : List String -> Maybe Schema
parseSchema ("String" :: xs)
= case xs of
[] => Just SString
_ => do xs_sch <- parseSchema xs
Just (SString .+. xs_sch)
parseSchema ("Int" :: xs)
= case xs of
[] => Just SInt
_ => do xs_sch <- parseSchema xs
Just (SInt .+. xs_sch)
parseSchema ("Char" :: xs)
= case xs of
[] => Just SInt
_ => do xs_sch <- parseSchema xs
Just (SChar .+. xs_sch)
parseSchema _ = Nothing
parseCommand : (schema : Schema) -> String -> String -> Maybe (Command schema)
parseCommand schema "add" rest = do restok <- parseBySchema schema rest
Just (Add restok)
parseCommand schema "get" "" = Just (Get Nothing)
parseCommand schema "get" val = case all isDigit (unpack val) of
False => Nothing
True => Just (Get (Just (cast val)))
parseCommand schema "quit" "" = Just Quit
parseCommand schema "schema" rest
= case parseSchema (words rest) of
Nothing => Nothing
Just schemaok => Just (SetSchema schemaok)
parseCommand _ _ _ = Nothing
parse : (schema : Schema) -> (input : String) -> Maybe (Command schema)
parse schema input = case span (/= ' ') input of
(cmd, args) => parseCommand schema cmd (trim args)
display : SchemaType schema -> String
display {schema = SString} item = show item
display {schema = SInt} item = show item
display {schema = SChar} item = show item
display {schema = (y .+. z)} (iteml, itemr) = display iteml ++ ", " ++
display itemr
getEntry : (pos : Integer) -> (store : DataStore) ->
Maybe (String, DataStore)
getEntry pos store
= let store_items = items store in
case integerToFin pos (size store) of
Nothing => Just ("Out of range\n", store)
Just id => Just (display (index id (items store)) ++ "\n", store)
showAll : Nat -> Vect size (SchemaType schema) -> String
showAll idx [] = ""
showAll idx (x :: xs) = show idx ++ ": " ++ display x ++ "\n" ++
showAll (idx + 1) xs
processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store input
= case parse (schema store) input of
Nothing => Just ("Invalid command\n", store)
Just (Add item) =>
Just ("ID " ++ show (size store) ++ "\n", addToStore store item)
Just (SetSchema schema') =>
case setSchema store schema' of
Nothing => Just ("Can't update schema when entries in store\n", store)
Just store' => Just ("OK\n", store')
Just (Get (Just pos)) => getEntry pos store
Just (Get Nothing) => Just (showAll 0 (items store) ++ "\n", store)
Just Quit => Nothing
main : IO ()
main = replWith (MkData (SString .+. SString .+. SInt) _ []) "Command: " processInput
================================================
FILE: Chapter6/Maybe.idr
================================================
maybeAdd : Maybe Int -> Maybe Int -> Maybe Int
maybeAdd x y = case x of
Nothing => Nothing
Just x_val => case y of
Nothing => Nothing
Just y_val => Just (x_val + y_val)
maybeAdd' : Maybe Int -> Maybe Int -> Maybe Int
maybeAdd' x y = x >>= \x_val =>
y >>= \y_val =>
Just (x_val + y_val)
maybeAdd'' : Maybe Int -> Maybe Int -> Maybe Int
maybeAdd'' x y = do x_val <- x
y_val <- y
Just (x_val + y_val)
================================================
FILE: Chapter6/Printf.idr
================================================
data Format = Number Format
| Str Format
| Lit String Format
| End
PrintfType : Format -> Type
PrintfType (Number fmt) = (i : Int) -> PrintfType fmt
PrintfType (Str fmt) = (str : String) -> PrintfType fmt
PrintfType (Lit str fmt) = PrintfType fmt
PrintfType End = String
printfFmt : (fmt : Format) -> (acc : String) -> PrintfType fmt
printfFmt (Number fmt) acc = \i => printfFmt fmt (acc ++ show i)
printfFmt (Str fmt) acc = \str => printfFmt fmt (acc ++ str)
printfFmt (Lit lit fmt) acc = printfFmt fmt (acc ++ lit)
printfFmt End acc = acc
toFormat : (xs : List Char) -> Format
toFormat [] = End
toFormat ('%' :: 'd' :: chars) = Number (toFormat chars)
toFormat ('%' :: 's' :: chars) = Str (toFormat chars)
toFormat ('%' :: chars) = Lit "%" (toFormat chars)
toFormat (c :: chars) = case toFormat chars of
Lit lit chars' => Lit (strCons c lit) chars'
fmt => Lit (strCons c "") fmt
printf : (fmt : String) -> PrintfType (toFormat (unpack fmt))
printf fmt = printfFmt _ ""
================================================
FILE: Chapter6/TypeFuns.idr
================================================
import Data.Vect
StringOrInt : Bool -> Type
StringOrInt False = String
StringOrInt True = Int
getStringOrInt : (isInt : Bool) -> StringOrInt isInt
getStringOrInt False = "Ninety four"
getStringOrInt True = 94
valToString : (isInt : Bool) -> StringOrInt isInt -> String
valToString False y = trim y
valToString True y = cast y
valToString' : (isInt : Bool) -> (case isInt of
False => String
True => Int) -> String
valToString' False y = trim y
valToString' True y = cast y
================================================
FILE: Chapter6/TypeSynonyms.idr
================================================
import Data.Vect
tri : Vect 3 (Double, Double)
tri = [(0.0, 0.0), (3.0, 0.0), (0.0, 4.0)]
Position : Type
Position = (Double, Double)
tri' : Vect 3 Position
tri' = [(0.0, 0.0), (3.0, 0.0), (0.0, 4.0)]
Polygon : Nat -> Type
Polygon n = Vect n Position
tri'' : Polygon 3
tri'' = [(0.0, 0.0), (3.0, 0.0), (0.0, 4.0)]
================================================
FILE: Chapter7/Album.idr
================================================
record Album where
constructor MkAlbum
artist : String
title : String
year : Integer
help : Album
help = MkAlbum "The Beatles" "Help" 1965
rubbersoul : Album
rubbersoul = MkAlbum "The Beatles" "Rubber Soul" 1965
clouds : Album
clouds = MkAlbum "Joni Mitchell" "Clouds" 1969
hunkydory : Album
hunkydory = MkAlbum "David Bowie" "Hunky Dory" 1971
heroes : Album
heroes = MkAlbum "David Bowie" "Heroes" 1977
collection : List Album
collection = [help, rubbersoul, clouds, hunkydory, heroes]
Eq Album where
(==) (MkAlbum artist title year) (MkAlbum artist' title' year')
= artist == artist' && title == title' && year == year'
Ord Album where
compare (MkAlbum artist title year) (MkAlbum artist' title' year')
= case compare artist artist' of
EQ => case compare year year' of
EQ => compare title title'
diff_year => diff_year
diff_artist => diff_artist
Show Album where
show (MkAlbum artist title year)
= title ++ " by " ++ artist ++ " (released " ++ show year ++ ")"
================================================
FILE: Chapter7/Eq.idr
================================================
occurrences : Eq ty => (item : ty) -> (values : List ty) -> Nat
occurrences item [] = 0
occurrences item (value :: values) = case x == item of
False => occurrences item values
True => 1 + occurrences item values
data Matter = Solid | Liquid | Gas
Eq Matter where
(==) Solid Solid = True
(==) Liquid Liquid = True
(==) Gas Gas = True
(==) _ _ = False
================================================
FILE: Chapter7/Exercises/ex_7_1.idr
================================================
data Shape = Triangle Double Double
| Rectangle Double Double
| Circle Double
area : Shape -> Double
area (Triangle base height) = 0.5 * base * height
area (Rectangle length height) = length * height
area (Circle radius) = pi * radius * radius
{- 1 -}
Eq Shape where
(==) (Triangle base height) (Triangle base' height')
= base == base' && height == height'
(==) (Rectangle length height) (Rectangle length' height')
= length == length' && height == height'
(==) (Circle radius) (Circle radius') = radius == radius'
(==) _ _ = False
{- 2 -}
Ord Shape where
compare x y = compare (area x) (area y)
testShapes : List Shape
testShapes = [Circle 3, Triangle 3 9, Rectangle 2 6, Circle 4,
Rectangle 2 7]
================================================
FILE: Chapter7/Exercises/ex_7_2.idr
================================================
data Expr num = Val num
| Add (Expr num) (Expr num)
| Sub (Expr num) (Expr num)
| Mul (Expr num) (Expr num)
| Div (Expr num) (Expr num)
| Abs (Expr num)
eval : (Neg num, Integral num) => Expr num -> num
eval (Val x) = x
eval (Add x y) = eval x + eval y
eval (Sub x y) = eval x - eval y
eval (Mul x y) = eval x * eval y
eval (Div x y) = eval x `div` eval y
eval (Abs x) = abs (eval x)
Num ty => Num (Expr ty) where
(+) = Add
(*) = Mul
fromInteger = Val . fromInteger
Neg ty => Neg (Expr ty) where
negate x = 0 - x
(-) = Sub
abs = Abs
{- 1 -}
showOp : Show a => String -> a -> a -> String
showOp op x y = "(" ++ show x ++ op ++ show y ++ ")"
Show ty => Show (Expr ty) where
show (Val x) = show x
show (Add x y) = showOp " + " x y
show (Sub x y) = showOp " - " x y
show (Mul x y) = showOp " * " x y
show (Div x y) = showOp " / " x y
show (Abs x) = "abs " ++ show x
{- 2 -}
(Neg a, Integral a, Eq a) => Eq (Expr a) where
(==) x y = eval x == eval y
{- 3 -}
(Neg num, Integral num) => Cast (Expr num) num where
cast orig = eval orig
================================================
FILE: Chapter7/Exercises/ex_7_3_1.idr
================================================
data Expr num = Val num
| Add (Expr num) (Expr num)
| Sub (Expr num) (Expr num)
| Mul (Expr num) (Expr num)
| Div (Expr num) (Expr num)
| Abs (Expr num)
eval : (Neg num, Integral num) => Expr num -> num
eval (Val x) = x
eval (Add x y) = eval x + eval y
eval (Sub x y) = eval x - eval y
eval (Mul x y) = eval x * eval y
eval (Div x y) = eval x `div` eval y
eval (Abs x) = abs (eval x)
Num ty => Num (Expr ty) where
(+) = Add
(*) = Mul
fromInteger = Val . fromInteger
Neg ty => Neg (Expr ty) where
negate x = 0 - x
(-) = Sub
abs = Abs
Functor Expr where
map f (Val x) = Val (f x)
map f (Add x y) = Add (map f x) (map f y)
map f (Sub x y) = Sub (map f x) (map f y)
map f (Mul x y) = Mul (map f x) (map f y)
map f (Div x y) = Div (map f x) (map f y)
map f (Abs x) = Abs (map f x)
================================================
FILE: Chapter7/Exercises/ex_7_3_2.idr
================================================
data Vect : Nat -> Type -> Type where
Nil : Vect Z a
(::) : a -> Vect k a -> Vect (S k) a
%name Vect xs, ys
Eq a => Eq (Vect n a) where
(==) [] [] = True
(==) (x :: xs) (y :: ys) = x == y && xs == ys
Foldable (Vect n) where
foldr f acc [] = acc
foldr f acc (x :: xs) = f x (foldr f acc xs)
================================================
FILE: Chapter7/Expr.idr
================================================
data Expr num = Val num
| Add (Expr num) (Expr num)
| Sub (Expr num) (Expr num)
| Mul (Expr num) (Expr num)
| Div (Expr num) (Expr num)
| Abs (Expr num)
eval : (Neg num, Integral num) => Expr num -> num
eval (Val x) = x
eval (Add x y) = eval x + eval y
eval (Sub x y) = eval x - eval y
eval (Mul x y) = eval x * eval y
eval (Div x y) = eval x `div` eval y
eval (Abs x) = abs (eval x)
Num ty => Num (Expr ty) where
(+) = Add
(*) = Mul
fromInteger = Val . fromInteger
Neg ty => Neg (Expr ty) where
negate x = 0 - x
(-) = Sub
abs = Abs
================================================
FILE: Chapter7/Fold.idr
================================================
totalLen : List String -> Nat
totalLen xs = foldr (\str, len => length str + len) 0 xs
================================================
FILE: Chapter7/Tree.idr
================================================
data Tree elem = Empty
| Node (Tree elem) elem (Tree elem)
Eq elem => Eq (Tree elem) where
(==) Empty Empty = True
(==) (Node left e right) (Node left' e' right')
= left == left' && e == e' && right == right'
(==) _ _ = False
Functor Tree where
map f Empty = Empty
map f (Node left e right)
= Node (map f left)
(f e)
(map f right)
Foldable Tree where
foldr f acc Empty = acc
foldr f acc (Node left e right) = let leftfold = foldr f acc left
rightfold = foldr f leftfold right in
f e rightfold
================================================
FILE: Chapter8/AppendVec.idr
================================================
import Data.Vect
append_nil : Vect m elem -> Vect (plus m 0) elem
append_nil {m} xs = rewrite plusZeroRightNeutral m in xs
append_xs : Vect (S (m + k)) elem -> Vect (plus m (S k)) elem
append_xs {m} {k} xs = rewrite sym (plusSuccRightSucc m k) in xs
append : Vect n elem -> Vect m elem -> Vect (m + n) elem
append [] ys = append_nil ys
append (x :: xs) ys = append_xs (x :: append xs ys)
================================================
FILE: Chapter8/CheckEqDec.idr
================================================
zeroNotSuc : (0 = S k) -> Void
zeroNotSuc Refl impossible
sucNotZero : (S k = 0) -> Void
sucNotZero Refl impossible
noRec : (contra : (k = j) -> Void) -> (S k = S j) -> Void
noRec contra Refl = contra Refl
checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Dec (num1 = num2)
checkEqNat Z Z = Yes Refl
checkEqNat Z (S k) = No zeroNotSuc
checkEqNat (S k) Z = No sucNotZero
checkEqNat (S k) (S j) = case checkEqNat k j of
Yes prf => Yes (cong prf)
No contra => No (noRec contra)
================================================
FILE: Chapter8/CheckEqMaybe.idr
================================================
checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Maybe (num1 = num2)
checkEqNat Z Z = Just Refl
checkEqNat Z (S k) = Nothing
checkEqNat (S k) Z = Nothing
checkEqNat (S k) (S j) = case checkEqNat k j of
Nothing => Nothing
Just prf => Just (cong prf)
================================================
FILE: Chapter8/EqNat.idr
================================================
data EqNat : Nat -> Nat -> Type where
Same : (x : Nat) -> EqNat x x
sameS : (k : Nat) -> (j : Nat) -> (eq : EqNat k j) -> EqNat (S k) (S j)
sameS k k (Same k) = Same (S k)
checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Maybe (EqNat num1 num2)
checkEqNat Z Z = Just (Same Z)
checkEqNat Z (S k) = Nothing
checkEqNat (S k) Z = Nothing
checkEqNat (S k) (S j) = case checkEqNat k j of
Nothing => Nothing
Just eq => Just (sameS _ _ eq)
================================================
FILE: Chapter8/ExactLength.idr
================================================
data Vect : Nat -> Type -> Type where
Nil : Vect Z a
(::) : a -> Vect k a -> Vect (S k) a
%name Vect xs, ys, zs
data EqNat : Nat -> Nat -> Type where
Same : (x : Nat) -> EqNat x x
sameS : (k : Nat) -> (j : Nat) -> (eq : EqNat k j) -> EqNat (S k) (S j)
sameS k k (Same k) = Same (S k)
checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Maybe (EqNat num1 num2)
checkEqNat Z Z = Just (Same Z)
checkEqNat Z (S k) = Nothing
checkEqNat (S k) Z = Nothing
checkEqNat (S k) (S j) = case checkEqNat k j of
Nothing => Nothing
Just eq => Just (sameS _ _ eq)
exactLength : (len : Nat) -> (input : Vect m a) -> Maybe (Vect len a)
exactLength {m} len input = case checkEqNat m len of
Nothing => Nothing
Just (Same len) => Just input
================================================
FILE: Chapter8/ExactLengthDec.idr
================================================
data Vect : Nat -> Type -> Type where
Nil : Vect Z a
(::) : a -> Vect k a -> Vect (S k) a
%name Vect xs, ys, zs
exactLength : (len : Nat) -> (input : Vect m a) -> Maybe (Vect len a)
exactLength {m} len input = case decEq m len of
Yes Refl => Just input
No contra => Nothing
================================================
FILE: Chapter8/Exercises/ex_8_1.idr
================================================
{- 1 -}
same_cons : {xs : List a} -> {ys : List a} ->
xs = ys -> x :: xs = x :: ys
same_cons Refl = Refl
{- 2 -}
same_lists : {xs : List a} -> {ys : List a} ->
x = y -> xs = ys -> x :: xs = y :: ys
same_lists Refl Refl = Refl
{- 3 -}
data ThreeEq : a -> b -> c -> Type where
AllSame : ThreeEq x x x
{- 4 -}
allSameS : (x, y, z : Nat) -> ThreeEq x y z -> ThreeEq (S x) (S y) (S z)
allSameS x x x AllSame = AllSame
-- If you add a successor to three equal Nats, the results are all equal
================================================
FILE: Chapter8/Exercises/ex_8_2.idr
================================================
import Data.Vect
{- 1 -}
myPlusCommutes : (n : Nat) -> (m : Nat) -> n + m = m + n
myPlusCommutes Z m = rewrite plusZeroRightNeutral m in Refl
myPlusCommutes (S k) m = rewrite myPlusCommutes k m in
rewrite plusSuccRightSucc m k in Refl
{- 2 -}
reverseProof_nil : Vect n a -> Vect (plus n 0) a
reverseProof_nil {n} xs = rewrite plusZeroRightNeutral n in xs
reverseProof_xs : Vect (S n + k) a -> Vect (plus n (S k)) a
reverseProof_xs {n} {k} xs = rewrite sym (plusSuccRightSucc n k) in xs
myReverse : Vect n a -> Vect n a
myReverse xs = reverse' [] xs
where reverse' : Vect n a -> Vect m a -> Vect (n+m) a
reverse' acc [] = reverseProof_nil acc
reverse' acc (x :: xs)
= reverseProof_xs (reverse' (x::acc) xs)
================================================
FILE: Chapter8/Exercises/ex_8_3.idr
================================================
data Vect : Nat -> Type -> Type where
Nil : Vect Z a
(::) : a -> Vect k a -> Vect (S k) a
%name Vect xs, ys, zs
{- 1 -}
headUnequal : DecEq a => {xs : Vect n a} -> {ys : Vect n a} ->
(contra : (x = y) -> Void) -> (x :: xs) = (y :: ys) -> Void
headUnequal contra Refl = contra Refl
tailUnequal : DecEq a => {xs : Vect n a} -> {ys : Vect n a} ->
(contra : (xs = ys) -> Void) -> (x :: xs) = (y :: ys) -> Void
tailUnequal contra Refl = contra Refl
{- 2 -}
DecEq a => DecEq (Vect n a) where
decEq [] [] = Yes Refl
decEq (x :: xs) (y :: ys) = case decEq x y of
No contra => No (headUnequal contra)
Yes Refl => case decEq xs ys of
Yes Refl => Yes Refl
No contra => No (tailUnequal contra)
================================================
FILE: Chapter8/ReverseVec.idr
================================================
import Data.Vect
myReverse1 : Vect n a -> Vect n a
myReverse1 [] = []
myReverse1 {n = S k} (x :: xs)
= let result = myReverse1 xs ++ [x] in
rewrite plusCommutative 1 k in result
myReverse : Vect n a -> Vect n a
myReverse [] = []
myReverse (x :: xs) = reverseProof (myReverse xs ++ [x])
where
reverseProof : Vect (k + 1) a -> Vect (S k) a
reverseProof {k} result = rewrite plusCommutative 1 k in result
================================================
FILE: Chapter8/TCVects.idr
================================================
import Data.Vect
test1 : Vect 4 Int
test1 = [1, 2, 3, 4]
test2: Vect (2 + 2) Int
test2 = ?test2_rhs
================================================
FILE: Chapter8/Void.idr
================================================
twoPlusTwoNotFive : 2 + 2 = 5 -> Void
twoPlusTwoNotFive Refl impossible
valueNotSuc : (x : Nat) -> x = S x -> Void
valueNotSuc _ Refl impossible
loop : Void
loop = loop
nohead : Void
nohead = getHead []
where
getHead : List Void -> Void
getHead (x :: xs) = x
================================================
FILE: Chapter9/Elem.idr
================================================
import Data.Vect
oneInVector : Elem 1 [1,2,3]
oneInVector = Here
maryInVector : Elem "Mary" ["Peter", "Paul", "Mary"]
maryInVector = There (There Here)
fourNotInVector : Elem 4 [1,2,3] -> Void
fourNotInVector (There (There (There Here))) impossible
fourNotInVector (There (There (There (There _)))) impossible
peteNotInVector : Elem "Pete" ["John", "Paul", "George", "Ringo"] -> Void
peteNotInVector (There (There (There (There Here)))) impossible
peteNotInVector (There (There (There (There (There _))))) impossible
================================================
FILE: Chapter9/ElemBool.idr
================================================
data Vect : Nat -> Type -> Type where
Nil : Vect Z a
(::) : a -> Vect k a -> Vect (S k) a
%name Vect xs, ys, zs
elem : Eq a => (value : a) -> (xs : Vect n a) -> Bool
elem value [] = False
elem value (x :: xs) = case value == x of
False => elem value xs
True => True
================================================
FILE: Chapter9/ElemType.idr
================================================
data Vect : Nat -> Type -> Type where
Nil : Vect Z a
(::) : a -> Vect k a -> Vect (S k) a
%name Vect xs, ys, zs
data Elem : a -> Vect k a -> Type where
Here : Elem x (x :: xs)
There : (later : Elem x xs) -> Elem x (y :: xs)
not_in_nil : Elem value [] -> Void
not_in_nil Here impossible
not_in_nil (There _) impossible
not_in_tail : (notThere : Elem value xs -> Void) -> (notHere : (value = x) -> Void) -> Elem value (x :: xs) -> Void
not_in_tail notThere notHere Here = notHere Refl
not_in_tail notThere notHere (There later) = notThere later
isElem : DecEq a => (value : a) -> (xs : Vect n a) -> Dec (Elem value xs)
isElem value [] = No not_in_nil
isElem value (x :: xs) = case decEq value x of
Yes Refl => Yes Here
No notHere => case isElem value xs of
Yes prf => Yes (There prf)
No notThere => No (not_in_tail notThere notHere)
================================================
FILE: Chapter9/Exercises/ex_9_1.idr
================================================
{- 1 -}
data Elem : a -> List a -> Type where
Here : Elem x (x :: xs)
There : Elem x xs -> Elem x (y :: xs)
{- 2 -}
data Last : List a -> a -> Type where
LastOne : Last [value] value
LastCons : (prf : Last xs value) -> Last (x :: xs) value
lastNotNil : (value : a) -> Last [] x -> Void
lastNotNil _ LastOne impossible
lastNotNil _ (LastCons _) impossible
lastNotCons : (contra : Last (x :: xs) value -> Void) ->
Last (y :: (x :: xs)) value -> Void
lastNotCons contra (LastCons prf) = contra prf
lastNotSingleton : (contra : (y = value) -> Void) -> Last [y] value -> Void
lastNotSingleton contra LastOne = contra Refl
lastNotSingleton _ (LastCons LastOne) impossible
lastNotSingleton _ (LastCons (LastCons _)) impossible
isLast : DecEq a => (xs : List a) -> (value : a) -> Dec (Last xs value)
isLast [] value = No (lastNotNil value)
isLast (y :: []) value = case decEq y value of
(Yes Refl) => Yes LastOne
(No contra) => No (lastNotSingleton contra)
isLast (y :: (x :: xs)) value = case isLast (x :: xs) value of
(Yes prf) => Yes (LastCons prf)
(No contra) => No (lastNotCons contra)
================================================
FILE: Chapter9/Hangman.idr
================================================
import Data.Vect
data WordState : (guesses : Nat) -> (letters : Nat) -> Type where
MkWordState : (word : String)
-> (missing : Vect letters Char)
-> WordState guesses_remaining letters
data Finished : Type where
Lost : (game : WordState 0 (S letters)) -> Finished
Won : (game : WordState (S guesses) 0) -> Finished
total
removeElem : (value : a) -> (xs : Vect (S n) a) ->
{auto prf : Elem value xs} ->
Vect n a
removeElem value (value :: ys) {prf = Here} = ys
removeElem {n = Z} value (y :: []) {prf = There later} = absurd later
removeElem {n = (S k)} value (y :: ys) {prf = There later}
= y :: removeElem value ys
processGuess : (letter : Char) -> WordState (S guesses) (S letters) ->
Either (WordState guesses (S letters))
(WordState (S guesses) letters)
processGuess letter (MkWordState word missing)
= case isElem letter missing of
Yes prf => Right (MkWordState word (removeElem letter missing))
No contra => Left (MkWordState word missing)
data ValidInput : List Char -> Type where
Letter : (c : Char) -> ValidInput [c]
isValidNil : ValidInput [] -> Void
isValidNil (Letter _) impossible
isValidTwo : ValidInput (x :: (y :: xs)) -> Void
isValidTwo (Letter _) impossible
isValidInput : (cs : List Char) -> Dec (ValidInput cs)
isValidInput [] = No isValidNil
isValidInput (x :: []) = Yes (Letter x)
isValidInput (x :: (y :: xs)) = No isValidTwo
isValidString : (s : String) -> Dec (ValidInput (unpack s))
isValidString s = isValidInput (unpack s)
readGuess : IO (x ** ValidInput x)
readGuess = do putStr "Guess: "
x <- getLine
case isValidString (toUpper x) of
Yes prf => pure (_ ** prf)
No contra => do putStrLn "Invalid guess"
readGuess
game : WordState (S guesses) (S letters) -> IO Finished
game {guesses} {letters} st
= do (_ ** Letter letter) <- readGuess
case processGuess letter st of
Left l => do putStrLn ("Wrong! " ++ show guesses ++
" guesses remaining")
case guesses of
Z => pure (Lost l)
S k => game l
Right r => do putStrLn "Right!"
case letters of
Z => pure (Won r)
S k => game r
main : IO ()
main = do result <- game {guesses=2} (MkWordState "Test" ['T', 'E', 'S'])
case result of
Lost (MkWordState word missing) =>
putStrLn ("You lose. The word was " ++ word)
Won game =>
putStrLn "You win!"
================================================
FILE: Chapter9/RemoveElem.idr
================================================
import Data.Vect
removeElem_v1 : DecEq a => (value : a) -> (xs : Vect (S n) a) -> Vect n a
removeElem_v1 value (x :: xs) = case decEq value x of
Yes prf => xs
No contra => ?removeElem_v1_rhs -- x :: removeElem_v1 value xs
Uninhabited (2 + 2 = 5) where
uninhabited Refl impossible
{-}
removeElem : (value : a) -> (xs : Vect (S n) a) ->
Elem value xs ->
Vect n a
removeElem value (value :: ys) Here = ys
removeElem {n = Z} value (y :: []) (There later) = absurd later
removeElem {n = (S k)} value (y :: ys) (There later)
= y :: removeElem value ys later
removeElem_auto : (value : a) -> (xs : Vect (S n) a) ->
{auto prf : Elem value xs} -> Vect n a
removeElem_auto value xs {prf} = removeElem value xs prf
-}
removeElem : (value : a) -> (xs : Vect (S n) a) ->
{auto prf : Elem value xs} ->
Vect n a
removeElem value (value :: ys) {prf = Here} = ys
removeElem {n = Z} value (y :: []) {prf = There later} = absurd later
removeElem {n = (S k)} value (y :: ys) {prf = There later}
= y :: removeElem value ys
my_elem : Eq a => (value : a) -> (xs : Vect n a) -> Bool
my_elem value [] = False
my_elem value (x :: xs) = case value == x of
False => my_elem value xs
True => True
not_in_nil : Elem value [] -> Void
not_in_nil Here impossible
not_in_nil (There _) impossible
not_in_tail : (contra1 : Elem value xs -> Void) -> (contra : (value = x) -> Void) -> Elem value (x :: xs) -> Void
not_in_tail contra1 contra Here = contra Refl
not_in_tail contra1 contra (There later) = contra1 later
my_decElem : DecEq a => (value : a) -> (xs : Vect n a) -> Dec (Elem value xs)
my_decElem value [] = No not_in_nil
my_decElem value (x :: xs)
= case decEq value x of
(Yes Refl) => Yes Here
(No contra) => case my_decElem value xs of
(Yes prf) => Yes (There prf)
(No contra1) => No (not_in_tail contra1 contra)
================================================
FILE: LICENSE
================================================
The MIT License (MIT)
Copyright (c) 2017 Manning Publications Co.
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.
================================================
FILE: README.md
================================================
# Type Driven Development with Idris
Sample code and exercise solutions from "Type Driven Development with Idris",
available from https://www.manning.com/books/type-driven-development-with-idris
gitextract_49twblj_/ ├── Chapter1/ │ ├── Exercises/ │ │ └── ex_1_2.idr │ ├── FCTypes.idr │ ├── Hello.idr │ └── HelloHole.idr ├── Chapter10/ │ ├── DLFail.idr │ ├── DataStore.idr │ ├── DescribeList.idr │ ├── DescribeList2.idr │ ├── Exercises/ │ │ ├── DataStore.idr │ │ ├── ex_10_1.idr │ │ ├── ex_10_2.idr │ │ └── ex_10_3.idr │ ├── IsSuffix.idr │ ├── MergeSort.idr │ ├── MergeSortView.idr │ ├── Reverse.idr │ ├── ReverseSnoc.idr │ ├── Shape.idr │ ├── Shape_abs.idr │ ├── SnocList.idr │ └── TestStore.idr ├── Chapter11/ │ ├── Arith.idr │ ├── ArithCmd.idr │ ├── ArithCmdDo.idr │ ├── ArithTotal.idr │ ├── Exercises/ │ │ ├── ex_11_1.idr │ │ ├── ex_11_2.idr │ │ └── ex_11_3.idr │ ├── Greet.idr │ ├── InfIO.idr │ ├── InfList.idr │ ├── Label.idr │ ├── RunIO.idr │ ├── StreamFail.idr │ └── Streams.idr ├── Chapter12/ │ ├── ArithState.idr │ ├── DataStore.idr │ ├── Exercises/ │ │ ├── ex_12_1.idr │ │ ├── ex_12_3a.idr │ │ └── ex_12_3b.idr │ ├── Record.idr │ ├── State.idr │ ├── StateMonad.idr │ ├── Traverse.idr │ ├── TreeLabel.idr │ ├── TreeLabelState.idr │ └── TreeLabelType.idr ├── Chapter13/ │ ├── Door.idr │ ├── Exercises/ │ │ ├── ex_13_1.idr │ │ └── ex_13_2.idr │ ├── Stack.idr │ ├── StackIO.idr │ └── Vending.idr ├── Chapter14/ │ ├── ATM.idr │ ├── DoorJam.idr │ ├── Exercises/ │ │ ├── ex_14_2_1.idr │ │ └── ex_14_2_2.idr │ └── Hangman.idr ├── Chapter15/ │ ├── AdderChannel.idr │ ├── ListProc.idr │ ├── Process.idr │ ├── ProcessIFace.idr │ ├── ProcessLib.idr │ ├── ProcessLoop.idr │ ├── ProcessState.idr │ ├── WordCount.idr │ └── test.txt ├── Chapter2/ │ ├── AveMain.idr │ ├── Average.idr │ ├── Double.idr │ ├── Exercises/ │ │ ├── ex_2.ibc │ │ ├── ex_2.idr │ │ ├── ex_2_counts.ibc │ │ ├── ex_2_counts.idr │ │ ├── ex_2_palindrome.ibc │ │ └── ex_2_palindrome.idr │ ├── Generic.idr │ ├── HOF.idr │ ├── Let_Where.idr │ ├── Partial.idr │ └── Reverse.idr ├── Chapter3/ │ ├── Exercises/ │ │ ├── ex_3_2.ibc │ │ ├── ex_3_2.idr │ │ ├── ex_3_3.ibc │ │ └── ex_3_3.idr │ ├── IsEven.idr │ ├── Matrix.idr │ ├── VecSort.idr │ ├── Vectors.idr │ ├── WordLength.idr │ ├── WordLength_vec.idr │ └── XOR.idr ├── Chapter4/ │ ├── BSTree.idr │ ├── DataStore.idr │ ├── Direction.idr │ ├── Exercises/ │ │ ├── ex_4_1.idr │ │ ├── ex_4_2.idr │ │ ├── ex_4_2_1.idr │ │ ├── ex_4_2_2.idr │ │ ├── ex_4_2_3.idr │ │ ├── ex_4_2_5.idr │ │ └── ex_4_3.idr │ ├── Generic.idr │ ├── Picture.idr │ ├── Shape.idr │ ├── SumInputs.idr │ ├── Tree.idr │ ├── TryIndex.idr │ ├── Vect.idr │ └── Vehicle.idr ├── Chapter5/ │ ├── DepPairs.idr │ ├── Do.idr │ ├── Exercises/ │ │ ├── ex_5_1.idr │ │ ├── ex_5_2_1.idr │ │ ├── ex_5_2_3.idr │ │ ├── ex_5_2_4.idr │ │ └── ex_5_3.idr │ ├── Hello.idr │ ├── Loops.idr │ ├── PrintLength.idr │ ├── ReadNum.idr │ └── ReadVect.idr ├── Chapter6/ │ ├── Adder.idr │ ├── DataStore.idr │ ├── DataStoreHoles.idr │ ├── Exercises/ │ │ ├── ex_6_2_1.idr │ │ ├── ex_6_2_2.idr │ │ ├── ex_6_2_3.idr │ │ ├── ex_6_3_1.idr │ │ ├── ex_6_3_2.idr │ │ └── ex_6_3_3.idr │ ├── Maybe.idr │ ├── Printf.idr │ ├── TypeFuns.idr │ └── TypeSynonyms.idr ├── Chapter7/ │ ├── Album.idr │ ├── Eq.idr │ ├── Exercises/ │ │ ├── ex_7_1.idr │ │ ├── ex_7_2.idr │ │ ├── ex_7_3_1.idr │ │ └── ex_7_3_2.idr │ ├── Expr.idr │ ├── Fold.idr │ └── Tree.idr ├── Chapter8/ │ ├── AppendVec.idr │ ├── CheckEqDec.idr │ ├── CheckEqMaybe.idr │ ├── EqNat.idr │ ├── ExactLength.idr │ ├── ExactLengthDec.idr │ ├── Exercises/ │ │ ├── ex_8_1.idr │ │ ├── ex_8_2.idr │ │ └── ex_8_3.idr │ ├── ReverseVec.idr │ ├── TCVects.idr │ └── Void.idr ├── Chapter9/ │ ├── Elem.idr │ ├── ElemBool.idr │ ├── ElemType.idr │ ├── Exercises/ │ │ └── ex_9_1.idr │ ├── Hangman.idr │ └── RemoveElem.idr ├── LICENSE └── README.md
Condensed preview — 164 files, each showing path, character count, and a content snippet. Download the .json file or copy for the full structured content (186K chars).
[
{
"path": "Chapter1/Exercises/ex_1_2.idr",
"chars": 793,
"preview": "{-\n\n1. Anything where the list is the same length as the input. We don't know\nthe types of elements contained in the lis"
},
{
"path": "Chapter1/FCTypes.idr",
"chars": 443,
"preview": "StringOrInt : Bool -> Type\nStringOrInt x = case x of\n True => Int\n False => Stri"
},
{
"path": "Chapter1/Hello.idr",
"chars": 64,
"preview": "module Main\n\nmain : IO ()\nmain = putStrLn \"Hello, Idris world!\"\n"
},
{
"path": "Chapter1/HelloHole.idr",
"chars": 54,
"preview": "module Main\n\nmain : IO ()\nmain = putStrLn ?greeting\n\n\n"
},
{
"path": "Chapter10/DLFail.idr",
"chars": 145,
"preview": "describe_list_end : List Int -> String\ndescribe_list_end [] = \"Empty\"\ndescribe_list_end (xs ++ [x]) = \"Non-empty, initia"
},
{
"path": "Chapter10/DataStore.idr",
"chars": 1104,
"preview": "module DataStore\n\nimport Data.Vect\n\ninfixr 5 .+.\n\npublic export\ndata Schema = SString | SInt | (.+.) Schema Schema\n\npubl"
},
{
"path": "Chapter10/DescribeList.idr",
"chars": 628,
"preview": "data ListLast : List a -> Type where\n Empty : ListLast []\n NonEmpty : (xs : List a) -> (x : a) -> ListLast (xs +"
},
{
"path": "Chapter10/DescribeList2.idr",
"chars": 564,
"preview": "data ListLast : List a -> Type where\n Empty : ListLast []\n NonEmpty : (xs : List a) -> (x : a) -> ListLast (xs +"
},
{
"path": "Chapter10/Exercises/DataStore.idr",
"chars": 1099,
"preview": "module DataStore\n\nimport Data.Vect\n\ninfixr 5 .+.\n\npublic export\ndata Schema = SString | SInt | (.+.) Schema Schema\n\npubl"
},
{
"path": "Chapter10/Exercises/ex_10_1.idr",
"chars": 737,
"preview": "{- 1 -}\n\ndata TakeN : List a -> Type where\n Fewer : TakeN xs\n Exact : (n_xs : List a) -> TakeN (n_xs ++ rest)\n\nt"
},
{
"path": "Chapter10/Exercises/ex_10_2.idr",
"chars": 1265,
"preview": "import Data.Vect\n\nimport Data.List.Views\nimport Data.Vect.Views\nimport Data.Nat.Views\n\n{- 1 -}\n\ntotal\nequalSuffix : Eq a"
},
{
"path": "Chapter10/Exercises/ex_10_3.idr",
"chars": 1299,
"preview": "import DataStore\n\nimport Data.Vect\n\n{- 1 -}\n\ntestStore : DataStore (SString .+. SInt)\ntestStore = addToStore (\"First\", 1"
},
{
"path": "Chapter10/IsSuffix.idr",
"chars": 450,
"preview": "import Data.List.Views\n\ntotal\nisSuffix : Eq a => List a -> List a -> Bool\nisSuffix input1 input2 with (snocList input1)\n"
},
{
"path": "Chapter10/MergeSort.idr",
"chars": 983,
"preview": "import Debug.Trace\n\ndata SplitList : List a -> Type where\n SplitNil : SplitList []\n SplitOne : SplitList [x]\n "
},
{
"path": "Chapter10/MergeSortView.idr",
"chars": 320,
"preview": "import Data.List.Views\n\nmergeSort : Ord a => List a -> List a\nmergeSort input with (splitRec input)\n mergeSort [] | Spl"
},
{
"path": "Chapter10/Reverse.idr",
"chars": 500,
"preview": "data ListLast : List a -> Type where\n Empty : ListLast []\n NonEmpty : (xs : List a) -> (x : a) -> ListLast (xs +"
},
{
"path": "Chapter10/ReverseSnoc.idr",
"chars": 156,
"preview": "data SnocList ty = Empty | Snoc (SnocList ty) ty\n\nreverseSnoc : SnocList ty -> List ty\nreverseSnoc Empty = []\nreverseSno"
},
{
"path": "Chapter10/Shape.idr",
"chars": 428,
"preview": "module Shape\n\npublic export\ndata Shape = Triangle Double Double\n | Rectangle Double Double\n | Circle"
},
{
"path": "Chapter10/Shape_abs.idr",
"chars": 607,
"preview": "module Shape_abs\n\nexport\ndata Shape = Triangle Double Double\n | Rectangle Double Double\n | Circle Do"
},
{
"path": "Chapter10/SnocList.idr",
"chars": 887,
"preview": "data SnocList : List a -> Type where\n Empty : SnocList []\n Snoc : (rec : SnocList xs) -> SnocList (xs ++ [x])\n\ns"
},
{
"path": "Chapter10/TestStore.idr",
"chars": 914,
"preview": "import DataStore\n\ntestStore : DataStore (SString .+. SString .+. SInt)\ntestStore = addToStore (\"Mercury\", \"Mariner 10\", "
},
{
"path": "Chapter11/Arith.idr",
"chars": 908,
"preview": "import Data.Primitives.Views\nimport System\n\nquiz : Stream Int -> (score : Nat) -> IO ()\nquiz (num1 :: num2 :: nums) scor"
},
{
"path": "Chapter11/ArithCmd.idr",
"chars": 2080,
"preview": "import Data.Primitives.Views\nimport System\n\n%default total\n\ndata Command : Type -> Type where\n PutStr : String -> Co"
},
{
"path": "Chapter11/ArithCmdDo.idr",
"chars": 2735,
"preview": "import Data.Primitives.Views\nimport System\n\n%default total\n\ndata Command : Type -> Type where\n PutStr : String -> Co"
},
{
"path": "Chapter11/ArithTotal.idr",
"chars": 1309,
"preview": "import Data.Primitives.Views\nimport System\n\n%default total\n\ndata InfIO : Type where\n Do : IO a -> (a -> Inf InfIO) -"
},
{
"path": "Chapter11/Exercises/ex_11_1.idr",
"chars": 1737,
"preview": "import Data.Primitives.Views\n\n{- 1 -}\n\nevery_other : Stream a -> Stream a\nevery_other (x :: y :: xs) = y :: every_other "
},
{
"path": "Chapter11/Exercises/ex_11_2.idr",
"chars": 1001,
"preview": "{- Preamble, solution below -}\n\nimport Data.Primitives.Views\nimport System\n\n%default total\n\ndata InfIO : Type where\n "
},
{
"path": "Chapter11/Exercises/ex_11_3.idr",
"chars": 1979,
"preview": "import Data.Primitives.Views\nimport System\n\n%default total\n\ndata Command : Type -> Type where\n PutStr : String -> Co"
},
{
"path": "Chapter11/Greet.idr",
"chars": 274,
"preview": "%default total\n\ndata InfIO : Type where\n Do : IO a -> (a -> Inf InfIO) -> InfIO\n\n(>>=) : IO a -> (a -> Inf InfIO) ->"
},
{
"path": "Chapter11/InfIO.idr",
"chars": 719,
"preview": "%default total\n\ndata InfIO : Type where\n Do : IO a -> (a -> Inf InfIO) -> InfIO\n\n(>>=) : IO a -> (a -> Inf InfIO) ->"
},
{
"path": "Chapter11/InfList.idr",
"chars": 571,
"preview": "data InfList : Type -> Type where\n (::) : (value : elem) -> Inf (InfList elem) -> InfList elem\n\n%name InfList xs, ys"
},
{
"path": "Chapter11/Label.idr",
"chars": 200,
"preview": "\nlabelFrom : Integer -> List a -> List (Integer, a)\nlabelFrom lbl [] = []\nlabelFrom lbl (val :: vals) = (lbl, val) :: la"
},
{
"path": "Chapter11/RunIO.idr",
"chars": 783,
"preview": "%default total\n\ndata RunIO : Type -> Type where\n Quit : a -> RunIO a\n Do : IO a -> (a -> Inf (RunIO b)) -> RunIO"
},
{
"path": "Chapter11/StreamFail.idr",
"chars": 227,
"preview": "countFrom : Integer -> List Integer\ncountFrom n = n :: countFrom (n + 1)\n\nlabelWith : List Integer -> List a -> List (In"
},
{
"path": "Chapter11/Streams.idr",
"chars": 241,
"preview": "labelWith : Stream labelType -> List a -> List (labelType, a)\nlabelWith lbls [] = []\nlabelWith (lbl :: lbls) (val :: val"
},
{
"path": "Chapter12/ArithState.idr",
"chars": 4361,
"preview": "import Data.Primitives.Views\nimport System\n\n%default total\n\nrecord Score where\n constructor MkScore\n correct"
},
{
"path": "Chapter12/DataStore.idr",
"chars": 642,
"preview": "module Main\n\nimport Data.Vect\n\ninfixr 5 .+.\n\ndata Schema = SString | SInt | (.+.) Schema Schema\n\nSchemaType : Schema -> "
},
{
"path": "Chapter12/Exercises/ex_12_1.idr",
"chars": 1056,
"preview": "import Control.Monad.State\n\ndata Tree a = Empty\n | Node (Tree a) a (Tree a)\n\ntestTree : Tree String\ntestTree "
},
{
"path": "Chapter12/Exercises/ex_12_3a.idr",
"chars": 4660,
"preview": "import Data.Primitives.Views\nimport System\n\n%default total\n\nrecord Score where\n constructor MkScore\n correct"
},
{
"path": "Chapter12/Exercises/ex_12_3b.idr",
"chars": 794,
"preview": "\nrecord Votes where\n constructor MkVotes\n upvotes : Integer\n downvotes : Integer\n\nrecord Article where"
},
{
"path": "Chapter12/Record.idr",
"chars": 187,
"preview": "record Book where\n constructor MkBook\n title : String\n author : String\n\nrecord Album where\n cons"
},
{
"path": "Chapter12/State.idr",
"chars": 134,
"preview": "import Control.Monad.State\n\nincrement : Nat -> State Nat ()\nincrement inc = do current <- get\n put (cu"
},
{
"path": "Chapter12/StateMonad.idr",
"chars": 1465,
"preview": "data State : (stateType : Type) -> Type -> Type where\n Get : State stateType stateType\n Put : stateType -> State"
},
{
"path": "Chapter12/Traverse.idr",
"chars": 259,
"preview": "crew : List String\ncrew = [\"Lister\", \"Rimmer\", \"Kryten\", \"Cat\"]\n\nmain : IO ()\nmain = do putStr \"Display Crew? \"\n "
},
{
"path": "Chapter12/TreeLabel.idr",
"chars": 880,
"preview": "data Tree a = Empty\n | Node (Tree a) a (Tree a)\n\ntestTree : Tree String\ntestTree = Node (Node (Node Empty \"Ji"
},
{
"path": "Chapter12/TreeLabelState.idr",
"chars": 849,
"preview": "import Control.Monad.State\n\ndata Tree a = Empty\n | Node (Tree a) a (Tree a)\n\ntestTree : Tree String\ntestTree "
},
{
"path": "Chapter12/TreeLabelType.idr",
"chars": 1825,
"preview": "data Tree a = Empty\n | Node (Tree a) a (Tree a)\n\ntestTree : Tree String\ntestTree = Node (Node (Node Empty \"Ji"
},
{
"path": "Chapter13/Door.idr",
"chars": 512,
"preview": "data DoorState = DoorOpen | DoorClosed\n\ndata DoorCmd : Type -> DoorState -> DoorState -> Type where\n Open : DoorCmd "
},
{
"path": "Chapter13/Exercises/ex_13_1.idr",
"chars": 1820,
"preview": "namespace Q1\n\n data DoorState = DoorOpen | DoorClosed\n\n data DoorCmd : Type -> DoorState -> DoorState -> Type where\n "
},
{
"path": "Chapter13/Exercises/ex_13_2.idr",
"chars": 5046,
"preview": "import Data.Vect\n\ndata StackCmd : Type -> Nat -> Nat -> Type where\n Push : Integer -> StackCmd () height (S height)\n"
},
{
"path": "Chapter13/Stack.idr",
"chars": 1082,
"preview": "import Data.Vect\n\ndata StackCmd : Type -> Nat -> Nat -> Type where\n Push : Integer -> StackCmd () height (S height)\n"
},
{
"path": "Chapter13/StackIO.idr",
"chars": 2960,
"preview": "import Data.Vect\n\ndata StackCmd : Type -> Nat -> Nat -> Type where\n Push : Integer -> StackCmd () height (S height)\n"
},
{
"path": "Chapter13/Vending.idr",
"chars": 3413,
"preview": "VendState : Type\nVendState = (Nat, Nat)\n\ndata Input = COIN \n | VEND \n | CHANGE \n | REFILL "
},
{
"path": "Chapter14/ATM.idr",
"chars": 3250,
"preview": "import Data.Vect\n\ndata ATMState = Ready | CardInserted | Session\ndata PINCheck = CorrectPIN | IncorrectPIN\n\nPIN : Type\nP"
},
{
"path": "Chapter14/DoorJam.idr",
"chars": 1822,
"preview": "data DoorState = DoorOpen | DoorClosed\n\ndata DoorResult = OK | Jammed\n\ndata DoorCmd : (ty : Type) -> DoorState -> (ty ->"
},
{
"path": "Chapter14/Exercises/ex_14_2_1.idr",
"chars": 1487,
"preview": "data Access = LoggedOut | LoggedIn\ndata PwdCheck = Correct | Incorrect\n\ndata ShellCmd : (ty : Type) -> Access -> (ty -> "
},
{
"path": "Chapter14/Exercises/ex_14_2_2.idr",
"chars": 3031,
"preview": "VendState : Type\nVendState = (Nat, Nat)\n\ndata Input = COIN \n | VEND \n | CHANGE \n | REFILL "
},
{
"path": "Chapter14/Hangman.idr",
"chars": 5854,
"preview": "import Data.Vect\n\n%default total\n\ndata GameState : Type where\n NotRunning : GameState\n Running : (guesses : Nat)"
},
{
"path": "Chapter15/AdderChannel.idr",
"chars": 732,
"preview": "import System.Concurrency.Channels\n\ndata Message = Add Nat Nat\n\nadder : IO ()\nadder = do Just sender_chan <- listen 1\n "
},
{
"path": "Chapter15/ListProc.idr",
"chars": 795,
"preview": "import ProcessLib\n\ndata ListAction : Type where\n Length : List elem -> ListAction\n Append : List elem -> List el"
},
{
"path": "Chapter15/Process.idr",
"chars": 1983,
"preview": "import System.Concurrency.Channels\n\ndata Message = Add Nat Nat\n\ndata MessagePID = MkMessage PID\n\ndata Process : Type -> "
},
{
"path": "Chapter15/ProcessIFace.idr",
"chars": 3836,
"preview": "import System.Concurrency.Channels\n\ndata Message = Add Nat Nat\n\nAdderType : Message -> Type\nAdderType (Add x y) = Nat\n\nd"
},
{
"path": "Chapter15/ProcessLib.idr",
"chars": 2991,
"preview": "module ProcessLib\n\nimport System.Concurrency.Channels\n\n%default total\n\nexport\ndata MessagePID : (iface : reqType -> Type"
},
{
"path": "Chapter15/ProcessLoop.idr",
"chars": 2591,
"preview": "import System.Concurrency.Channels\n\ndata Message = Add Nat Nat\n\ndata MessagePID = MkMessage PID\n\ndata Process : Type -> "
},
{
"path": "Chapter15/ProcessState.idr",
"chars": 3129,
"preview": "import System.Concurrency.Channels\n\ndata Message = Add Nat Nat\n\ndata MessagePID = MkMessage PID\n\ndata ProcState = Ready "
},
{
"path": "Chapter15/WordCount.idr",
"chars": 1923,
"preview": "import ProcessLib\n\nrecord WCData where\n constructor MkWCData\n wordCount : Nat\n lineCount : Nat\n\ndoCount : (content : "
},
{
"path": "Chapter15/test.txt",
"chars": 35,
"preview": "test test\ntest\ntest test test\ntest\n"
},
{
"path": "Chapter2/AveMain.idr",
"chars": 214,
"preview": "module Main\n\nimport Average\n\nshowAverage : String -> String\nshowAverage str = \"The average word length is: \" ++\n "
},
{
"path": "Chapter2/Average.idr",
"chars": 488,
"preview": "module Average\n\n||| Calculate the average length of words in a string.\n||| @str a string containing words separated by w"
},
{
"path": "Chapter2/Double.idr",
"chars": 37,
"preview": "double : Int -> Int\ndouble x = x + x\n"
},
{
"path": "Chapter2/Exercises/ex_2.idr",
"chars": 955,
"preview": "{-\n\n1. (String, String, String)\n List String\n ((Char, String), Char)\n\n-}\n\n{- 2 -}\n\npalindrome : String -> Bool\npalin"
},
{
"path": "Chapter2/Exercises/ex_2_counts.idr",
"chars": 233,
"preview": "module Main\n\ncounts : String -> (Nat, Nat)\ncounts str = (length (words str), length str)\n\nmain : IO ()\nmain = repl \"Ente"
},
{
"path": "Chapter2/Exercises/ex_2_palindrome.idr",
"chars": 291,
"preview": "module Main\n\npalindrome : String -> Bool\npalindrome str = let strL = toLower str in\n strL == reverse"
},
{
"path": "Chapter2/Generic.idr",
"chars": 333,
"preview": "identityInt : Int -> Int\nidentityInt x = x\n\nidentityString : String -> String\nidentityString x = x\n\nidentityBool : Bool "
},
{
"path": "Chapter2/HOF.idr",
"chars": 239,
"preview": "double : Num a => a -> a\ndouble x = x * x\n\ntwice : (a -> a) -> a -> a\ntwice f x = f (f x)\n\nShape : Type\nrotate : Shape -"
},
{
"path": "Chapter2/Let_Where.idr",
"chars": 310,
"preview": "longer : String -> String -> Nat\nlonger word1 word2\n = let len1 = length word1\n len2 = length word2 in\n "
},
{
"path": "Chapter2/Partial.idr",
"chars": 40,
"preview": "add : Int -> Int -> Int\nadd x y = x + y\n"
},
{
"path": "Chapter2/Reverse.idr",
"chars": 51,
"preview": "module Main\n\nmain : IO ()\nmain = repl \"> \" reverse\n"
},
{
"path": "Chapter3/Exercises/ex_3_2.idr",
"chars": 446,
"preview": "import Data.Vect\n\n{- 1 -}\n\nmy_length : List a -> Nat\nmy_length [] = 0\nmy_length (x :: xs) = 1 + my_length xs\n\n{- 2 -}\n\nm"
},
{
"path": "Chapter3/Exercises/ex_3_3.idr",
"chars": 1170,
"preview": "import Data.Vect\n\n{- 1 -}\n\ncreate_empties : Vect n (Vect 0 elem)\ncreate_empties = replicate _ []\n\ntranspose_mat : Vect m"
},
{
"path": "Chapter3/IsEven.idr",
"chars": 211,
"preview": "isEven' : Nat -> Bool\nisEven' Z = True\nisEven' (S k) = not (isEven' k)\n\nmutual\n isEven : Nat -> Bool\n isEven Z = True\n"
},
{
"path": "Chapter3/Matrix.idr",
"chars": 537,
"preview": "import Data.Vect\n\ncreateEmpties : Vect n (Vect 0 elem)\ncreateEmpties {n = Z} = []\ncreateEmpties {n = (S k)} = [] :: crea"
},
{
"path": "Chapter3/VecSort.idr",
"chars": 406,
"preview": "import Data.Vect\n\ninsert : Ord elem => (x : elem) -> (xsSorted : Vect k elem) -> Vect (S k) elem\ninsert x [] = [x]\ninser"
},
{
"path": "Chapter3/Vectors.idr",
"chars": 168,
"preview": "import Data.Vect\n\nfourInts : Vect 4 Int\nfourInts = [0, 1, 2, 3]\n\nsixInts : Vect 6 Int\nsixInts = [4, 5, 6, 7, 8, 9]\n\ntenI"
},
{
"path": "Chapter3/WordLength.idr",
"chars": 117,
"preview": "allLengths : List String -> List Nat\nallLengths [] = []\nallLengths (word :: words) = length word :: allLengths words\n"
},
{
"path": "Chapter3/WordLength_vec.idr",
"chars": 149,
"preview": "import Data.Vect\n\ntotal\nallLengths : Vect len String -> Vect len Nat\nallLengths [] = []\nallLengths (word :: words) = len"
},
{
"path": "Chapter3/XOR.idr",
"chars": 62,
"preview": "xor : Bool -> Bool -> Bool\nxor False y = y\nxor True y = not y\n"
},
{
"path": "Chapter4/BSTree.idr",
"chars": 488,
"preview": "data BSTree : Type -> Type where\n Empty : Ord elem => BSTree elem\n Node : Ord elem => (left : BSTree elem) -> (v"
},
{
"path": "Chapter4/DataStore.idr",
"chars": 1835,
"preview": "module Main\n\nimport Data.Vect\n\ndata DataStore : Type where\n MkData : (size : Nat) -> (items : Vect size String) -> D"
},
{
"path": "Chapter4/Direction.idr",
"chars": 193,
"preview": "data Direction = North | East | South | West\n\nturnClockwise : Direction -> Direction\nturnClockwise North = East\nturnCloc"
},
{
"path": "Chapter4/Exercises/ex_4_1.idr",
"chars": 2328,
"preview": "{- Support code -}\n\ndata Shape = ||| A triangle, with its base length and height\n Triangle Double Double\n "
},
{
"path": "Chapter4/Exercises/ex_4_2.idr",
"chars": 560,
"preview": "{- 1 -}\n\ndata PowerSource = Petrol | Pedal\n\ndata Vehicle : PowerSource -> Type where\n Bicycle : Vehicle Pedal\n U"
},
{
"path": "Chapter4/Exercises/ex_4_2_1.idr",
"chars": 560,
"preview": "{- 1 -}\n\ndata PowerSource = Petrol | Pedal\n\ndata Vehicle : PowerSource -> Type where\n Bicycle : Vehicle Pedal\n U"
},
{
"path": "Chapter4/Exercises/ex_4_2_2.idr",
"chars": 616,
"preview": "{- 2 -}\n\ndata PowerSource = Petrol | Pedal | Electric\n\ndata Vehicle : PowerSource -> Type where\n Bicycle : Vehicle P"
},
{
"path": "Chapter4/Exercises/ex_4_2_3.idr",
"chars": 268,
"preview": "data Vect : Nat -> Type -> Type where\n Nil : Vect Z a\n (::) : (x : a) -> (xs : Vect k a) -> Vect (S k) a\n\n%name"
},
{
"path": "Chapter4/Exercises/ex_4_2_5.idr",
"chars": 284,
"preview": "import Data.Vect\n\n{- 5 -}\n\nsumEntries : Num a => (pos : Integer) -> Vect n a -> Vect n a -> Maybe a\nsumEntries {n} pos x"
},
{
"path": "Chapter4/Exercises/ex_4_3.idr",
"chars": 2481,
"preview": "module Main\nimport Data.Vect\n\ndata DataStore : Type where\n MkData : (size : Nat) -> (items : Vect size String) -> Da"
},
{
"path": "Chapter4/Generic.idr",
"chars": 131,
"preview": "safeDivide : Double -> Double -> Maybe Double\nsafeDivide x y = if y == 0 then Nothing\n else Ju"
},
{
"path": "Chapter4/Picture.idr",
"chars": 1150,
"preview": "data Shape = ||| A triangle, with its base length and height\n Triangle Double Double\n | ||| A rect"
},
{
"path": "Chapter4/Shape.idr",
"chars": 442,
"preview": "data Shape = ||| A triangle, with its base length and height\n Triangle Double Double\n | ||| A rect"
},
{
"path": "Chapter4/SumInputs.idr",
"chars": 312,
"preview": "sumInputs : Integer -> String -> Maybe (String, Integer)\nsumInputs tot inp\n = let val = cast inp in\n if val < 0 "
},
{
"path": "Chapter4/Tree.idr",
"chars": 369,
"preview": "data Tree elem = Empty\n | Node (Tree elem) elem (Tree elem)\n\n%name Tree tree, tree1\n\ninsert : Ord elem => "
},
{
"path": "Chapter4/TryIndex.idr",
"chars": 206,
"preview": "import Data.Vect\n\ntryIndex : Integer -> Vect n a -> Maybe a\ntryIndex {n} i xs = case integerToFin i n of\n "
},
{
"path": "Chapter4/Vect.idr",
"chars": 359,
"preview": "data Vect : Nat -> Type -> Type where\n Nil : Vect Z a\n (::) : (x : a) -> (xs : Vect k a) -> Vect (S k) a\n\n%name"
},
{
"path": "Chapter4/Vehicle.idr",
"chars": 408,
"preview": "data PowerSource = Petrol | Pedal\n\ndata Vehicle : PowerSource -> Type where\n Bicycle : Vehicle Pedal\n Car : (fue"
},
{
"path": "Chapter5/DepPairs.idr",
"chars": 727,
"preview": "import Data.Vect\n\nanyVect : (n ** Vect n String)\nanyVect = (3 ** [\"Rod\", \"Jane\", \"Freddy\"])\n\nreadVect : IO (len ** Vect "
},
{
"path": "Chapter5/Do.idr",
"chars": 346,
"preview": "printTwoThings : IO ()\nprintTwoThings = do putStrLn \"Hello\"\n putStrLn \"World\"\n\nprintInput : IO ()\npri"
},
{
"path": "Chapter5/Exercises/ex_5_1.idr",
"chars": 695,
"preview": "{- 1 -}\n\nprintLonger : IO ()\nprintLonger = do putStr \"First string: \"\n str1 <- getLine\n "
},
{
"path": "Chapter5/Exercises/ex_5_2_1.idr",
"chars": 855,
"preview": "import System\n\n{- 1 -}\n\nreadNumber : IO (Maybe Nat)\nreadNumber = do\n input <- getLine\n if all isDigit (unpack input)\n "
},
{
"path": "Chapter5/Exercises/ex_5_2_3.idr",
"chars": 959,
"preview": "import System\n\n{- 3 -}\n\nreadNumber : IO (Maybe Nat)\nreadNumber = do\n input <- getLine\n if all isDigit (unpack input)\n "
},
{
"path": "Chapter5/Exercises/ex_5_2_4.idr",
"chars": 542,
"preview": "{- 4 -}\n\nmy_repl : (prompt : String) ->\n (fn : String -> String) -> IO ()\nmy_repl prompt fn\n = do putStr prom"
},
{
"path": "Chapter5/Exercises/ex_5_3.idr",
"chars": 1429,
"preview": "import Data.Vect\n\n{- 1 -}\n\nreadToBlank : IO (List String)\nreadToBlank = do x <- getLine\n case x of\n "
},
{
"path": "Chapter5/Hello.idr",
"chars": 114,
"preview": "module Main\n\nmain : IO ()\nmain = do\n putStr \"Enter your name: \"\n x <- getLine\n putStrLn (\"Hello \" ++ x ++ \"!\")\n"
},
{
"path": "Chapter5/Loops.idr",
"chars": 792,
"preview": "module Main\n\nimport System\n\ncountdown : (secs : Nat) -> IO ()\ncountdown Z = putStrLn \"Lift off!\"\ncountdown (S secs) = do"
},
{
"path": "Chapter5/PrintLength.idr",
"chars": 193,
"preview": "printLength : IO ()\nprintLength = putStr \"Input string: \" >>= \\_ =>\n getLine >>= \\input =>\n le"
},
{
"path": "Chapter5/ReadNum.idr",
"chars": 981,
"preview": "readNumber : IO (Maybe Nat)\nreadNumber = do\n input <- getLine\n if all isDigit (unpack input)\n then pure (Just (cas"
},
{
"path": "Chapter5/ReadVect.idr",
"chars": 669,
"preview": "import Data.Vect\n\nreadVectLen : (len : Nat) -> IO (Vect len String)\nreadVectLen Z = pure []\nreadVectLen (S k) = do x <- "
},
{
"path": "Chapter6/Adder.idr",
"chars": 294,
"preview": "AdderType : (numargs : Nat) -> Type -> Type\nAdderType Z numType = numType\nAdderType (S k) numType = (next : numType) -> "
},
{
"path": "Chapter6/DataStore.idr",
"chars": 4909,
"preview": "module Main\n\nimport Data.Vect\n\ninfixr 5 .+.\n\ndata Schema = SString | SInt | (.+.) Schema Schema\n\nSchemaType : Schema -> "
},
{
"path": "Chapter6/DataStoreHoles.idr",
"chars": 2138,
"preview": "module Main\n\nimport Data.Vect\n\ninfixr 5 .+.\n\ndata Schema = SString | SInt | (.+.) Schema Schema\n\nSchemaType : Schema -> "
},
{
"path": "Chapter6/Exercises/ex_6_2_1.idr",
"chars": 152,
"preview": "import Data.Vect\n\n{- 1 -}\n\nMatrix : Nat -> Nat -> Type\nMatrix n m = Vect n (Vect m Double)\n\ntestMatrix : Matrix 2 3\ntest"
},
{
"path": "Chapter6/Exercises/ex_6_2_2.idr",
"chars": 1452,
"preview": "data Format = Number Format\n | Str Format\n | Lit String Format\n | Ch Format\n "
},
{
"path": "Chapter6/Exercises/ex_6_2_3.idr",
"chars": 138,
"preview": "TupleVect : Nat -> Type -> Type\nTupleVect Z ty = ()\nTupleVect (S k) ty = (ty, TupleVect k ty)\n\ntest : TupleVect 4 Nat\nte"
},
{
"path": "Chapter6/Exercises/ex_6_3_1.idr",
"chars": 5367,
"preview": "module Main\n\nimport Data.Vect\n\ninfixr 5 .+.\n\ndata Schema = SString | SInt | SChar | (.+.) Schema Schema\n\nSchemaType : Sc"
},
{
"path": "Chapter6/Exercises/ex_6_3_2.idr",
"chars": 5703,
"preview": "module Main\n\nimport Data.Vect\n\ninfixr 5 .+.\n\ndata Schema = SString | SInt | SChar | (.+.) Schema Schema\n\nSchemaType : Sc"
},
{
"path": "Chapter6/Exercises/ex_6_3_3.idr",
"chars": 5355,
"preview": "module Main\n\nimport Data.Vect\n\ninfixr 5 .+.\n\ndata Schema = SString | SInt | SChar | (.+.) Schema Schema\n\nSchemaType : Sc"
},
{
"path": "Chapter6/Maybe.idr",
"chars": 590,
"preview": "maybeAdd : Maybe Int -> Maybe Int -> Maybe Int\nmaybeAdd x y = case x of\n Nothing => Nothing\n "
},
{
"path": "Chapter6/Printf.idr",
"chars": 1068,
"preview": "data Format = Number Format\n | Str Format\n | Lit String Format\n | End\n\nPrintfType : For"
},
{
"path": "Chapter6/TypeFuns.idr",
"chars": 554,
"preview": "import Data.Vect\n\nStringOrInt : Bool -> Type\nStringOrInt False = String\nStringOrInt True = Int\n\ngetStringOrInt : (isInt "
},
{
"path": "Chapter6/TypeSynonyms.idr",
"chars": 319,
"preview": "import Data.Vect\n\ntri : Vect 3 (Double, Double)\ntri = [(0.0, 0.0), (3.0, 0.0), (0.0, 4.0)]\n\nPosition : Type\nPosition = ("
},
{
"path": "Chapter7/Album.idr",
"chars": 1105,
"preview": "record Album where\n constructor MkAlbum\n artist : String\n title : String\n year : Integer\n\nhelp : Album\nhelp "
},
{
"path": "Chapter7/Eq.idr",
"chars": 452,
"preview": "occurrences : Eq ty => (item : ty) -> (values : List ty) -> Nat\noccurrences item [] = 0\noccurrences item (value :: value"
},
{
"path": "Chapter7/Exercises/ex_7_1.idr",
"chars": 779,
"preview": "data Shape = Triangle Double Double\n | Rectangle Double Double\n | Circle Double\n\narea : Shape -> Dou"
},
{
"path": "Chapter7/Exercises/ex_7_2.idr",
"chars": 1164,
"preview": "data Expr num = Val num\n | Add (Expr num) (Expr num)\n | Sub (Expr num) (Expr num)\n "
},
{
"path": "Chapter7/Exercises/ex_7_3_1.idr",
"chars": 898,
"preview": "data Expr num = Val num\n | Add (Expr num) (Expr num)\n | Sub (Expr num) (Expr num)\n "
},
{
"path": "Chapter7/Exercises/ex_7_3_2.idr",
"chars": 319,
"preview": "data Vect : Nat -> Type -> Type where\n Nil : Vect Z a\n (::) : a -> Vect k a -> Vect (S k) a\n\n%name Vect xs, ys\n\n"
},
{
"path": "Chapter7/Expr.idr",
"chars": 634,
"preview": "data Expr num = Val num\n | Add (Expr num) (Expr num)\n | Sub (Expr num) (Expr num)\n "
},
{
"path": "Chapter7/Fold.idr",
"chars": 87,
"preview": "totalLen : List String -> Nat\ntotalLen xs = foldr (\\str, len => length str + len) 0 xs\n"
},
{
"path": "Chapter7/Tree.idr",
"chars": 663,
"preview": "data Tree elem = Empty\n | Node (Tree elem) elem (Tree elem)\n\nEq elem => Eq (Tree elem) where\n (==) Empt"
},
{
"path": "Chapter8/AppendVec.idr",
"chars": 391,
"preview": "import Data.Vect\n\nappend_nil : Vect m elem -> Vect (plus m 0) elem\nappend_nil {m} xs = rewrite plusZeroRightNeutral m in"
},
{
"path": "Chapter8/CheckEqDec.idr",
"chars": 534,
"preview": "\nzeroNotSuc : (0 = S k) -> Void\nzeroNotSuc Refl impossible\n\nsucNotZero : (S k = 0) -> Void\nsucNotZero Refl impossible\n\nn"
},
{
"path": "Chapter8/CheckEqMaybe.idr",
"chars": 305,
"preview": "checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Maybe (num1 = num2)\ncheckEqNat Z Z = Just Refl\ncheckEqNat Z (S k) = Nothing"
},
{
"path": "Chapter8/EqNat.idr",
"chars": 497,
"preview": "data EqNat : Nat -> Nat -> Type where\n Same : (x : Nat) -> EqNat x x\n\nsameS : (k : Nat) -> (j : Nat) -> (eq : EqNat "
},
{
"path": "Chapter8/ExactLength.idr",
"chars": 859,
"preview": "data Vect : Nat -> Type -> Type where\n Nil : Vect Z a\n (::) : a -> Vect k a -> Vect (S k) a\n\n%name Vect xs, ys,"
},
{
"path": "Chapter8/ExactLengthDec.idr",
"chars": 353,
"preview": "data Vect : Nat -> Type -> Type where\n Nil : Vect Z a\n (::) : a -> Vect k a -> Vect (S k) a\n\n%name Vect xs, ys,"
},
{
"path": "Chapter8/Exercises/ex_8_1.idr",
"chars": 525,
"preview": "{- 1 -}\n\nsame_cons : {xs : List a} -> {ys : List a} ->\n xs = ys -> x :: xs = x :: ys\nsame_cons Refl = Refl\n\n"
},
{
"path": "Chapter8/Exercises/ex_8_2.idr",
"chars": 779,
"preview": "import Data.Vect\n\n{- 1 -}\n\nmyPlusCommutes : (n : Nat) -> (m : Nat) -> n + m = m + n\nmyPlusCommutes Z m = rewrite plusZer"
},
{
"path": "Chapter8/Exercises/ex_8_3.idr",
"chars": 910,
"preview": "data Vect : Nat -> Type -> Type where\n Nil : Vect Z a\n (::) : a -> Vect k a -> Vect (S k) a\n\n%name Vect xs, ys,"
},
{
"path": "Chapter8/ReverseVec.idr",
"chars": 437,
"preview": "import Data.Vect\n\n\nmyReverse1 : Vect n a -> Vect n a\nmyReverse1 [] = []\nmyReverse1 {n = S k} (x :: xs)\n = let res"
},
{
"path": "Chapter8/TCVects.idr",
"chars": 102,
"preview": "import Data.Vect\n\ntest1 : Vect 4 Int\ntest1 = [1, 2, 3, 4]\n\ntest2: Vect (2 + 2) Int\ntest2 = ?test2_rhs\n"
},
{
"path": "Chapter8/Void.idr",
"chars": 272,
"preview": "twoPlusTwoNotFive : 2 + 2 = 5 -> Void\ntwoPlusTwoNotFive Refl impossible\n\nvalueNotSuc : (x : Nat) -> x = S x -> Void\nvalu"
},
{
"path": "Chapter9/Elem.idr",
"chars": 522,
"preview": "import Data.Vect\n\noneInVector : Elem 1 [1,2,3]\noneInVector = Here\n\nmaryInVector : Elem \"Mary\" [\"Peter\", \"Paul\", \"Mary\"]\n"
},
{
"path": "Chapter9/ElemBool.idr",
"chars": 335,
"preview": "data Vect : Nat -> Type -> Type where\n Nil : Vect Z a\n (::) : a -> Vect k a -> Vect (S k) a\n\n%name Vect xs, ys,"
},
{
"path": "Chapter9/ElemType.idr",
"chars": 1015,
"preview": "data Vect : Nat -> Type -> Type where\n Nil : Vect Z a\n (::) : a -> Vect k a -> Vect (S k) a\n\n%name Vect xs, ys,"
},
{
"path": "Chapter9/Exercises/ex_9_1.idr",
"chars": 1258,
"preview": "{- 1 -}\n\ndata Elem : a -> List a -> Type where\n Here : Elem x (x :: xs)\n There : Elem x xs -> Elem x (y :: xs)\n\n"
},
{
"path": "Chapter9/Hangman.idr",
"chars": 2911,
"preview": "import Data.Vect\n\ndata WordState : (guesses : Nat) -> (letters : Nat) -> Type where\n MkWordState : (word : String)\n "
},
{
"path": "Chapter9/RemoveElem.idr",
"chars": 2184,
"preview": "import Data.Vect\n\nremoveElem_v1 : DecEq a => (value : a) -> (xs : Vect (S n) a) -> Vect n a\nremoveElem_v1 value (x :: xs"
},
{
"path": "LICENSE",
"chars": 1091,
"preview": "The MIT License (MIT)\n\nCopyright (c) 2017 Manning Publications Co.\n\nPermission is hereby granted, free of charge, to any"
},
{
"path": "README.md",
"chars": 196,
"preview": "# Type Driven Development with Idris\n\nSample code and exercise solutions from \"Type Driven Development with Idris\",\navai"
}
]
// ... and 5 more files (download for full content)
About this extraction
This page contains the full source code of the edwinb/TypeDD-Samples GitHub repository, extracted and formatted as plain text for AI agents and large language models (LLMs). The extraction includes 164 files (167.0 KB), approximately 49.5k tokens. Use this with OpenClaw, Claude, ChatGPT, Cursor, Windsurf, or any other AI tool that accepts text input. You can copy the full output to your clipboard or download it as a .txt file.
Extracted by GitExtract — free GitHub repo to text converter for AI. Built by Nikandr Surkov.