[ { "path": "Chapter1/Exercises/ex_1_2.idr", "content": "{-\n\n1. Anything where the list is the same length as the input. We don't know\nthe types of elements contained in the list, however, so we can't look at them.\nSome possibilities (there are many others!):\n\n - sorting the list\n - reversing the list\n - returning the input unchanged\n\n2. Anything where the output list is twice as long as the input.\nSome possibilities:\n\n - Duplicating each element\n - Returning the list appended to itself\n\n3. Anything where the output list is one item shorter than the input, which\nmust itself be non-empty. Some possibilities:\n\n - Returning all but the first element\n - Returning all but the last element\n\n4. The bounded number is likely to refer to a position in the list, so this\ncould be a function to return the element at that position.\n\n-}\n" }, { "path": "Chapter1/FCTypes.idr", "content": "StringOrInt : Bool -> Type\nStringOrInt x = case x of\n True => Int\n False => String\n\ngetStringOrInt : (x : Bool) -> StringOrInt x\ngetStringOrInt x = case x of\n True => 94\n False => \"Ninety four\"\n\nvalToString : (x : Bool) -> StringOrInt x -> String\nvalToString x val = case x of\n True => cast val\n False => val\n" }, { "path": "Chapter1/Hello.idr", "content": "module Main\n\nmain : IO ()\nmain = putStrLn \"Hello, Idris world!\"\n" }, { "path": "Chapter1/HelloHole.idr", "content": "module Main\n\nmain : IO ()\nmain = putStrLn ?greeting\n\n\n" }, { "path": "Chapter10/DLFail.idr", "content": "describe_list_end : List Int -> String\ndescribe_list_end [] = \"Empty\"\ndescribe_list_end (xs ++ [x]) = \"Non-empty, initial portion = \" ++ show xs\n" }, { "path": "Chapter10/DataStore.idr", "content": "module DataStore\n\nimport Data.Vect\n\ninfixr 5 .+.\n\npublic export\ndata Schema = SString | SInt | (.+.) Schema Schema\n\npublic export\nSchemaType : Schema -> Type\nSchemaType SString = String\nSchemaType SInt = Int\nSchemaType (x .+. y) = (SchemaType x, SchemaType y)\n\nexport\nrecord DataStore (schema : Schema) where\n constructor MkData\n size : Nat\n items : Vect size (SchemaType schema)\n\nexport\nempty : DataStore schema\nempty = MkData 0 []\n\nexport\naddToStore : (entry : SchemaType schema) ->\n (store : DataStore schema) ->\n DataStore schema \naddToStore entry (MkData _ items)\n = MkData _ (entry :: items)\n\npublic export\ndata StoreView : DataStore schema -> Type where\n SNil : StoreView empty \n SAdd : (rec : StoreView store) -> StoreView (addToStore entry store)\n\nstoreViewHelp : (items : Vect size (SchemaType schema)) -> \n StoreView (MkData size items)\nstoreViewHelp [] = SNil\nstoreViewHelp (entry :: xs) = SAdd (storeViewHelp xs)\n\nexport\nstoreView : (store : DataStore schema) -> StoreView store\nstoreView (MkData size items) \n = storeViewHelp items\n\n" }, { "path": "Chapter10/DescribeList.idr", "content": "data ListLast : List a -> Type where\n Empty : ListLast []\n NonEmpty : (xs : List a) -> (x : a) -> ListLast (xs ++ [x])\n\nlistLast : (xs : List a) -> ListLast xs\nlistLast [] = Empty\nlistLast (x :: xs) = case listLast xs of\n Empty => NonEmpty [] x\n NonEmpty xs y => NonEmpty (x :: xs) y\n\ndescribeHelper : (input : List Int) -> ListLast input -> String\ndescribeHelper [] Empty = \"Empty\"\ndescribeHelper (xs ++ [x]) (NonEmpty xs x)\n = \"Non-empty, initial portion = \" ++ show xs\n\ndescribeListEnd : List Int -> String\ndescribeListEnd xs = describeHelper xs (listLast xs)\n" }, { "path": "Chapter10/DescribeList2.idr", "content": "data ListLast : List a -> Type where\n Empty : ListLast []\n NonEmpty : (xs : List a) -> (x : a) -> ListLast (xs ++ [x])\n\nlistLast : (xs : List a) -> ListLast xs\nlistLast [] = Empty\nlistLast (x :: xs) = case listLast xs of\n Empty => NonEmpty [] x\n NonEmpty xs y => NonEmpty (x :: xs) y\n\ndescribe_list_end : List Int -> String\n\ndescribe_list_end input with (listLast input)\n describe_list_end [] | Empty = ?describe_list_end_rhs_1\n describe_list_end (xs ++ [x]) | (NonEmpty xs x) = ?describe_list_end_rhs_2\n" }, { "path": "Chapter10/Exercises/DataStore.idr", "content": "module DataStore\n\nimport Data.Vect\n\ninfixr 5 .+.\n\npublic export\ndata Schema = SString | SInt | (.+.) Schema Schema\n\npublic export\nSchemaType : Schema -> Type\nSchemaType SString = String\nSchemaType SInt = Int\nSchemaType (x .+. y) = (SchemaType x, SchemaType y)\n\nexport\nrecord DataStore (schema : Schema) where\n constructor MkData\n size : Nat\n items : Vect size (SchemaType schema)\n\nexport\nempty : DataStore schema\nempty = MkData 0 []\n\nexport\naddToStore : (entry : SchemaType schema) ->\n (store : DataStore schema) ->\n DataStore schema\naddToStore entry (MkData _ items)\n = MkData _ (entry :: items)\n\npublic export\ndata StoreView : DataStore schema -> Type where\n SNil : StoreView empty\n SAdd : (rec : StoreView store) -> StoreView (addToStore entry store)\n\nstoreViewHelp : (items : Vect size (SchemaType schema)) ->\n StoreView (MkData size items)\nstoreViewHelp [] = SNil\nstoreViewHelp (entry :: xs) = SAdd (storeViewHelp xs)\n\nexport\nstoreView : (store : DataStore schema) -> StoreView store\nstoreView (MkData size items)\n = storeViewHelp items\n" }, { "path": "Chapter10/Exercises/ex_10_1.idr", "content": "{- 1 -}\n\ndata TakeN : List a -> Type where\n Fewer : TakeN xs\n Exact : (n_xs : List a) -> TakeN (n_xs ++ rest)\n\ntakeN : (n : Nat) -> (xs : List a) -> TakeN xs\ntakeN Z xs = Exact []\ntakeN (S k) [] = Fewer\ntakeN (S k) (x :: xs) with (takeN k xs)\n takeN (S k) (x :: xs) | Fewer = Fewer\n takeN (S k) (x :: (n_xs ++ rest)) | Exact _ = Exact (x :: n_xs)\n\ngroupByN : (n : Nat) -> (xs : List a) -> List (List a)\ngroupByN n xs with (takeN n xs)\n groupByN n xs | Fewer = [xs]\n groupByN n (n_xs ++ rest) | (Exact n_xs) = n_xs :: groupByN n rest\n\n{- 2 -}\n\nhalves : List a -> (List a, List a)\nhalves input with (takeN (length input `div` 2) input)\n halves input | Fewer = (input, [])\n halves (n_xs ++ rest) | (Exact n_xs) = (n_xs, rest)\n" }, { "path": "Chapter10/Exercises/ex_10_2.idr", "content": "import Data.Vect\n\nimport Data.List.Views\nimport Data.Vect.Views\nimport Data.Nat.Views\n\n{- 1 -}\n\ntotal\nequalSuffix : Eq a => List a -> List a -> List a\nequalSuffix input1 input2 with (snocList input1)\n equalSuffix [] input2 | Empty = []\n equalSuffix (xs ++ [x]) input2 | (Snoc xsrec) with (snocList input2)\n equalSuffix (xs ++ [x]) [] | (Snoc xsrec) | Empty = []\n equalSuffix (xs ++ [x]) (ys ++ [y]) | (Snoc xsrec) | (Snoc ysrec) \n = if x == y \n then equalSuffix xs ys | xsrec | ysrec ++ [y]\n else []\n\n{- 2 -}\n\ntotal\nmergeSort : Ord a => Vect n a -> Vect n a\nmergeSort xs with (splitRec xs)\n mergeSort [] | SplitRecNil = []\n mergeSort [x] | SplitRecOne = [x]\n mergeSort (ys ++ zs) | (SplitRecPair lrec rrec) \n = merge (mergeSort ys | lrec) (mergeSort zs | rrec)\n\n{- 3 -}\n\ntotal\ntoBinary : Nat -> String\ntoBinary k with (halfRec k)\n toBinary Z | HalfRecZ = \"\"\n toBinary (n + n) | (HalfRecEven rec) = toBinary n | rec ++ \"0\"\n toBinary (S (n + n)) | (HalfRecOdd rec) = toBinary n | rec ++ \"1\"\n\n{- 4 -}\n\npalindrome : Eq a => List a -> Bool\npalindrome input with (vList input)\n palindrome [] | VNil = True\n palindrome [x] | VOne = True\n palindrome (x :: (xs ++ [y])) | (VCons rec) \n = x == y && palindrome xs\n\n" }, { "path": "Chapter10/Exercises/ex_10_3.idr", "content": "import DataStore\n\nimport Data.Vect\n\n{- 1 -}\n\ntestStore : DataStore (SString .+. SInt)\ntestStore = addToStore (\"First\", 1) $\n addToStore (\"Second\", 2) $\n empty\n\ngetValues : DataStore (SString .+. val_schema) ->\n List (SchemaType val_schema)\ngetValues input with (storeView input)\n getValues empty | SNil = []\n getValues (addToStore (key, value) store) | (SAdd rec)\n = value :: getValues store | rec\n\n{- 2 -}\n\nexport\ndata Shape = Triangle Double Double\n | Rectangle Double Double\n | Circle Double\n\nexport\ntriangle : Double -> Double -> Shape\ntriangle = Triangle\n\nexport\nrectangle : Double -> Double -> Shape\nrectangle = Rectangle\n\nexport\ncircle : Double -> Shape\ncircle = Circle\n\ndata ShapeView : Shape -> Type where\n STriangle : ShapeView (triangle base height)\n SRectangle : ShapeView (rectangle width height)\n SCircle : ShapeView (circle radius)\n\nshapeView : (s : Shape) -> ShapeView s\nshapeView (Triangle x y) = STriangle\nshapeView (Rectangle x y) = SRectangle\nshapeView (Circle x) = SCircle\n\narea : Shape -> Double\narea s with (shapeView s)\n area (triangle base height) | STriangle = 0.5 * base * height\n area (rectangle width height) | SRectangle = width * height\n area (circle radius) | SCircle = pi * radius * radius\n" }, { "path": "Chapter10/IsSuffix.idr", "content": "import Data.List.Views\n\ntotal\nisSuffix : Eq a => List a -> List a -> Bool\nisSuffix input1 input2 with (snocList input1)\n isSuffix [] input2 | Empty = False\n isSuffix (xs ++ [x]) input2 | (Snoc xsrec) with (snocList input2)\n isSuffix (xs ++ [x]) [] | (Snoc xsrec) | Empty = False\n isSuffix (xs ++ [x]) (ys ++ [y]) | (Snoc xsrec) | (Snoc ysrec) \n = if x == y then isSuffix xs ys | xsrec | ysrec\n else False\n\n" }, { "path": "Chapter10/MergeSort.idr", "content": "import Debug.Trace\n\ndata SplitList : List a -> Type where\n SplitNil : SplitList []\n SplitOne : SplitList [x]\n SplitPair : (lefts : List a) -> (rights : List a) ->\n SplitList (lefts ++ rights)\n\ntotal\nsplitList : (xs : List a) -> SplitList xs\nsplitList xs = splitListHelp xs xs\n where\n splitListHelp : (counter : List a) -> (xs : List a) -> SplitList xs\n splitListHelp _ [] = SplitNil\n splitListHelp _ [x] = SplitOne\n splitListHelp (_ :: _ :: ys) (x :: xs)\n = case splitListHelp ys xs of\n SplitNil => SplitOne\n SplitOne {x=y} => SplitPair [x] [y]\n SplitPair lefts rights => SplitPair (x :: lefts) rights\n splitListHelp _ xs = SplitPair [] xs\n\nmergeSort : Ord a => List a -> List a\nmergeSort input with (splitList input)\n mergeSort [] | SplitNil = []\n mergeSort [x] | SplitOne = [x]\n mergeSort (lefts ++ rights) | (SplitPair lefts rights)\n = merge (mergeSort lefts) (mergeSort rights)\n" }, { "path": "Chapter10/MergeSortView.idr", "content": "import Data.List.Views\n\nmergeSort : Ord a => List a -> List a\nmergeSort input with (splitRec input)\n mergeSort [] | SplitRecNil = []\n mergeSort [x] | SplitRecOne = [x]\n mergeSort (lefts ++ rights) | (SplitRecPair lrec rrec)\n = merge (mergeSort lefts | lrec)\n (mergeSort rights | rrec)\n" }, { "path": "Chapter10/Reverse.idr", "content": "data ListLast : List a -> Type where\n Empty : ListLast []\n NonEmpty : (xs : List a) -> (x : a) -> ListLast (xs ++ [x])\n\nlistLast : (xs : List a) -> ListLast xs\nlistLast [] = Empty\nlistLast (x :: xs) = case listLast xs of\n Empty => NonEmpty [] x\n NonEmpty xs y => NonEmpty (x :: xs) y\n\nmyReverse : List a -> List a\nmyReverse input with (listLast input)\n myReverse [] | Empty = []\n myReverse (xs ++ [x]) | (NonEmpty xs x) = x :: myReverse xs\n" }, { "path": "Chapter10/ReverseSnoc.idr", "content": "data SnocList ty = Empty | Snoc (SnocList ty) ty\n\nreverseSnoc : SnocList ty -> List ty\nreverseSnoc Empty = []\nreverseSnoc (Snoc xs x) = x :: reverseSnoc xs\n" }, { "path": "Chapter10/Shape.idr", "content": "module Shape\n\npublic export\ndata Shape = Triangle Double Double\n | Rectangle Double Double\n | Circle Double\n\nprivate\nrectangle_area : Double -> Double -> Double\nrectangle_area width height = width * height\n\nexport\narea : Shape -> Double\narea (Triangle base height) = 0.5 * rectangle_area base height\narea (Rectangle length height) = rectangle_area length height\narea (Circle radius) = pi * radius * radius\n\n\n" }, { "path": "Chapter10/Shape_abs.idr", "content": "module Shape_abs\n\nexport\ndata Shape = Triangle Double Double\n | Rectangle Double Double\n | Circle Double\n\nexport\ntriangle : Double -> Double -> Shape\ntriangle = Triangle\n\nexport\nrectangle : Double -> Double -> Shape\nrectangle = Rectangle\n\nexport\ncircle : Double -> Shape\ncircle = Circle\n\nprivate\nrectangle_area : Double -> Double -> Double\nrectangle_area width height = width * height\n\nexport\narea : Shape -> Double\narea (Triangle base height) = 0.5 * rectangle_area base height\narea (Rectangle length height) = rectangle_area length height\narea (Circle radius) = pi * radius * radius\n\n\n" }, { "path": "Chapter10/SnocList.idr", "content": "data SnocList : List a -> Type where\n Empty : SnocList []\n Snoc : (rec : SnocList xs) -> SnocList (xs ++ [x])\n\nsnocListHelp : (snoc : SnocList input) -> (rest : List a) -> SnocList (input ++ rest)\nsnocListHelp {input} snoc [] = rewrite appendNilRightNeutral input in snoc\nsnocListHelp {input} snoc (x :: xs)\n = rewrite appendAssociative input [x] xs in snocListHelp (Snoc snoc) xs\n\nsnocList : (xs : List a) -> SnocList xs\nsnocList xs = snocListHelp Empty xs\n\nmy_reverse_help : (input : List a) -> SnocList input -> List a\nmy_reverse_help [] Empty = []\nmy_reverse_help (xs ++ [x]) (Snoc rec) = x :: my_reverse_help xs rec\n\nmy_reverse1 : List a -> List a\nmy_reverse1 input = my_reverse_help input (snocList input)\n\nmy_reverse : List a -> List a\nmy_reverse input with (snocList input)\n my_reverse [] | Empty = []\n my_reverse (xs ++ [x]) | (Snoc rec) = x :: my_reverse xs | rec\n" }, { "path": "Chapter10/TestStore.idr", "content": "import DataStore\n\ntestStore : DataStore (SString .+. SString .+. SInt)\ntestStore = addToStore (\"Mercury\", \"Mariner 10\", 1974) $\n addToStore (\"Venus\", \"Venera\", 1961) $\n addToStore (\"Uranus\", \"Voyager 2\", 1986) $\n addToStore (\"Pluto\", \"New Horizons\", 2015) $\n empty\n\nlistItems : DataStore schema -> List (SchemaType schema)\nlistItems input with (storeView input)\n listItems empty | SNil = []\n listItems (addToStore entry store) | (SAdd rec) \n = entry :: listItems store | rec\n\nfilterKeys : (test : SchemaType val_schema -> Bool) ->\n DataStore (SString .+. val_schema) -> List String\nfilterKeys test input with (storeView input)\n filterKeys test input | SNil = []\n filterKeys test (addToStore (key, value) store) | (SAdd rec) \n = if test value \n then key :: filterKeys test store | rec\n else filterKeys test store | rec\n" }, { "path": "Chapter11/Arith.idr", "content": "import Data.Primitives.Views\nimport System\n\nquiz : Stream Int -> (score : Nat) -> IO ()\nquiz (num1 :: num2 :: nums) score\n = do putStrLn (\"Score so far: \" ++ show score)\n putStr (show num1 ++ \" * \" ++ show num2 ++ \"? \")\n answer <- getLine\n if cast answer == num1 * num2\n then do putStrLn \"Correct!\"\n quiz nums (score + 1)\n else do putStrLn (\"Wrong, the answer is \" ++ show (num1 * num2))\n quiz nums score\n\nrandoms : Int -> Stream Int\nrandoms seed = let seed' = 1664525 * seed + 1013904223 in\n (seed' `shiftR` 2) :: randoms seed'\n\narithInputs : Int -> Stream Int\narithInputs seed = map bound (randoms seed)\n where\n bound : Int -> Int\n bound x with (divides x 12)\n bound ((12 * div) + rem) | (DivBy prf) = rem + 1\n\nmain : IO ()\nmain = do seed <- time\n quiz (arithInputs (fromInteger seed)) 0\n" }, { "path": "Chapter11/ArithCmd.idr", "content": "import Data.Primitives.Views\nimport System\n\n%default total\n\ndata Command : Type -> Type where\n PutStr : String -> Command ()\n GetLine : Command String\n\ndata ConsoleIO : Type -> Type where\n Quit : a -> ConsoleIO a\n Do : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b\n\n(>>=) : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b\n(>>=) = Do\n\ndata Fuel = Dry | More (Lazy Fuel)\n\nrunCommand : Command a -> IO a\nrunCommand (PutStr x) = putStr x\nrunCommand GetLine = getLine\n\nrun : Fuel -> ConsoleIO a -> IO (Maybe a)\nrun fuel (Quit val) = do pure (Just val)\nrun (More fuel) (Do c f) = do res <- runCommand c\n run fuel (f res)\nrun Dry p = pure Nothing\n\nrandoms : Int -> Stream Int\nrandoms seed = let seed' = 1664525 * seed + 1013904223 in\n (seed' `shiftR` 2) :: randoms seed'\n\narithInputs : Int -> Stream Int\narithInputs seed = map bound (randoms seed)\n where\n bound : Int -> Int\n bound x with (divides x 12)\n bound ((12 * div) + rem) | (DivBy prf) = abs rem + 1\n\nmutual\n correct : Stream Int -> (score : Nat) -> ConsoleIO Nat\n correct nums score\n = do PutStr \"Correct!\\n\"\n quiz nums (score + 1)\n\n wrong : Stream Int -> Int -> (score : Nat) -> ConsoleIO Nat\n wrong nums ans score\n = do PutStr (\"Wrong, the answer is \" ++ show ans ++ \"\\n\")\n quiz nums score\n\n quiz : Stream Int -> (score : Nat) -> ConsoleIO Nat\n quiz (num1 :: num2 :: nums) score\n = do PutStr (\"Score so far: \" ++ show score ++ \"\\n\")\n PutStr (show num1 ++ \" * \" ++ show num2 ++ \"? \")\n answer <- GetLine\n if toLower answer == \"quit\" then Quit score else\n if (cast answer == num1 * num2)\n then correct nums score\n else wrong nums (num1 * num2) score\n\npartial\nforever : Fuel\nforever = More forever\n\npartial\nmain : IO ()\nmain = do seed <- time\n Just score <- run forever (quiz (arithInputs (fromInteger seed)) 0)\n | Nothing => putStrLn \"Ran out of fuel\"\n putStrLn (\"Final score: \" ++ show score)\n" }, { "path": "Chapter11/ArithCmdDo.idr", "content": "import Data.Primitives.Views\nimport System\n\n%default total\n\ndata Command : Type -> Type where\n PutStr : String -> Command ()\n GetLine : Command String\n\n Pure : ty -> Command ty\n Bind : Command a -> (a -> Command b) -> Command b\n\ndata ConsoleIO : Type -> Type where\n Quit : a -> ConsoleIO a\n Do : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b\n\nnamespace CommandDo\n (>>=) : Command a -> (a -> Command b) -> Command b\n (>>=) = Bind\n\nnamespace ConsoleDo\n (>>=) : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b\n (>>=) = Do\n\ndata Fuel = Dry | More (Lazy Fuel)\n\nrunCommand : Command a -> IO a\nrunCommand (PutStr x) = putStr x\nrunCommand GetLine = getLine\nrunCommand (Pure val) = pure val\nrunCommand (Bind c f) = do res <- runCommand c\n runCommand (f res)\n\nrun : Fuel -> ConsoleIO a -> IO (Maybe a)\nrun fuel (Quit val) = do pure (Just val)\nrun (More fuel) (Do c f) = do res <- runCommand c\n run fuel (f res)\nrun Dry p = pure Nothing\n\nrandoms : Int -> Stream Int\nrandoms seed = let seed' = 1664525 * seed + 1013904223 in\n (seed' `shiftR` 2) :: randoms seed'\n\narithInputs : Int -> Stream Int\narithInputs seed = map bound (randoms seed)\n where\n bound : Int -> Int\n bound x with (divides x 12)\n bound ((12 * div) + rem) | (DivBy prf) = abs rem + 1\n\nmutual\n correct : Stream Int -> (score : Nat) -> ConsoleIO Nat\n correct nums score\n = do PutStr \"Correct!\\n\"\n quiz nums (score + 1)\n\n wrong : Stream Int -> Int -> (score : Nat) -> ConsoleIO Nat\n wrong nums ans score\n = do PutStr (\"Wrong, the answer is \" ++ show ans ++ \"\\n\")\n quiz nums score\n\n data Input = Answer Int\n | QuitCmd\n\n readInput : (prompt : String) -> Command Input\n readInput prompt \n = do PutStr prompt\n answer <- GetLine\n if toLower answer == \"quit\" \n then Pure QuitCmd \n else Pure (Answer (cast answer))\n\n quiz : Stream Int -> (score : Nat) -> ConsoleIO Nat\n quiz (num1 :: num2 :: nums) score\n = do PutStr (\"Score so far: \" ++ show score ++ \"\\n\")\n input <- readInput (show num1 ++ \" * \" ++ show num2 ++ \"? \")\n case input of\n Answer answer => if answer == num1 * num2 \n then correct nums score\n else wrong nums (num1 * num2) score\n QuitCmd => Quit score\n\npartial\nforever : Fuel\nforever = More forever\n\npartial\nmain : IO ()\nmain = do seed <- time\n Just score <- run forever (quiz (arithInputs (fromInteger seed)) 0)\n | Nothing => putStrLn \"Ran out of fuel\"\n putStrLn (\"Final score: \" ++ show score)\n" }, { "path": "Chapter11/ArithTotal.idr", "content": "import Data.Primitives.Views\nimport System\n\n%default total\n\ndata InfIO : Type where\n Do : IO a -> (a -> Inf InfIO) -> InfIO\n\n(>>=) : IO a -> (a -> Inf InfIO) -> InfIO\n(>>=) = Do\n\ndata Fuel = Dry | More (Lazy Fuel)\n\nrun : Fuel -> InfIO -> IO ()\nrun (More fuel) (Do c f) = do res <- c\n run fuel (f res)\nrun Dry p = putStrLn \"Out of fuel\"\n\nrandoms : Int -> Stream Int\nrandoms seed = let seed' = 1664525 * seed + 1013904223 in\n (seed' `shiftR` 2) :: randoms seed'\n\narithInputs : Int -> Stream Int\narithInputs seed = map bound (randoms seed)\n where\n bound : Int -> Int\n bound x with (divides x 12)\n bound ((12 * div) + rem) | (DivBy prf) = abs rem + 1\n\nquiz : Stream Int -> (score : Nat) -> InfIO\nquiz (num1 :: num2 :: nums) score\n = do putStrLn (\"Score so far: \" ++ show score)\n putStr (show num1 ++ \" * \" ++ show num2 ++ \"? \")\n answer <- getLine\n if (cast answer == num1 * num2)\n then do putStrLn \"Correct!\"\n quiz nums (score + 1)\n else do putStrLn (\"Wrong, the answer is \" ++ show (num1 * num2))\n quiz nums score\n\npartial\nforever : Fuel\nforever = More forever\n\npartial\nmain : IO ()\nmain = do seed <- time\n run forever (quiz (arithInputs (fromInteger seed)) 0)\n" }, { "path": "Chapter11/Exercises/ex_11_1.idr", "content": "import Data.Primitives.Views\n\n{- 1 -}\n\nevery_other : Stream a -> Stream a\nevery_other (x :: y :: xs) = y :: every_other xs\n\n{- 2 -}\n\ndata InfList : Type -> Type where\n (::) : (value : elem) -> Inf (InfList elem) -> InfList elem\n\n%name InfList xs, ys, zs\n\ncountFrom : Integer -> InfList Integer\ncountFrom x = x :: Delay (countFrom (x + 1))\n\ngetPrefix : (count : Nat) -> InfList a -> List a\ngetPrefix Z xs = []\ngetPrefix (S k) (value :: xs) = value :: getPrefix k xs\n\nFunctor InfList where\n map func (value :: xs) = func value :: map func xs\n\n{- 3 -}\n\nrandoms : Int -> Stream Int\nrandoms seed = let seed' = 1664525 * seed + 1013904223 in\n (seed' `shiftR` 2) :: randoms seed'\n\ndata Face = Heads | Tails\n\ntotal\ngetFace : Int -> Face\ngetFace x with (divides x 2)\n getFace ((2 * div) + rem) | (DivBy prf)\n = case rem of\n 0 => Heads\n _ => Tails\n\ncoinFlips : Nat -> Stream Int -> List Face\ncoinFlips k rnds = map getFace (take k rnds)\n\n{- 4 -}\n\nsquare_root_approx : (number : Double) -> (approx : Double) -> Stream Double\nsquare_root_approx number approx\n = let next = (approx + (number / approx)) / 2 in\n approx :: square_root_approx number next\n\n{- 5 -}\n\nsquare_root_bound : (max : Nat) -> (number : Double) -> (bound : Double) ->\n (approxs : Stream Double) -> Double\nsquare_root_bound Z number bound (x :: xs) = x\nsquare_root_bound (S k) number bound (x :: xs) =\n if (abs (x * x - number) < bound)\n then x\n else square_root_bound k number bound xs\n\nsquare_root : (number : Double) -> Double\nsquare_root number = square_root_bound 100 number 0.00000000001\n (square_root_approx number number)\n" }, { "path": "Chapter11/Exercises/ex_11_2.idr", "content": "{- Preamble, solution below -}\n\nimport Data.Primitives.Views\nimport System\n\n%default total\n\ndata InfIO : Type where\n Do : IO a -> (a -> Inf InfIO) -> InfIO\n\n(>>=) : IO a -> (a -> Inf InfIO) -> InfIO\n(>>=) = Do\n\ndata Fuel = Dry | More (Lazy Fuel)\n\nrun : Fuel -> InfIO -> IO ()\nrun (More fuel) (Do c f) = do res <- c\n run fuel (f res)\nrun Dry p = putStrLn \"Out of fuel\"\n\nrandoms : Int -> Stream Int\nrandoms seed = let seed' = 1664525 * seed + 1013904223 in\n (seed' `shiftR` 2) :: randoms seed'\n\narithInputs : Int -> Stream Int\narithInputs seed = map bound (randoms seed)\n where\n bound : Int -> Int\n bound x with (divides x 12)\n bound ((12 * div) + rem) | (DivBy prf) = abs rem + 1\n\npartial\nforever : Fuel\nforever = More forever\n\n{- Solution -}\n\ntotalREPL : (prompt : String) -> (action : String -> String) -> InfIO\ntotalREPL prompt action = \n do putStr prompt\n inp <- getLine\n putStr (action inp)\n totalREPL prompt action\n\n" }, { "path": "Chapter11/Exercises/ex_11_3.idr", "content": "import Data.Primitives.Views\nimport System\n\n%default total\n\ndata Command : Type -> Type where\n PutStr : String -> Command ()\n GetLine : Command String\n\ndata ConsoleIO : Type -> Type where\n Quit : a -> ConsoleIO a\n Do : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b\n\n(>>=) : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b\n(>>=) = Do\n\ndata Fuel = Dry | More (Lazy Fuel)\n\nrunCommand : Command a -> IO a\nrunCommand (PutStr x) = putStr x\nrunCommand GetLine = getLine\n\nrun : Fuel -> ConsoleIO a -> IO (Maybe a)\nrun fuel (Quit val) = do pure (Just val)\nrun (More fuel) (Do c f) = do res <- runCommand c\n run fuel (f res)\nrun Dry p = pure Nothing\n\nrandoms : Int -> Stream Int\nrandoms seed = let seed' = 1664525 * seed + 1013904223 in\n (seed' `shiftR` 2) :: randoms seed'\n\narithInputs : Int -> Stream Int\narithInputs seed = map bound (randoms seed)\n where\n bound : Int -> Int\n bound x with (divides x 12)\n bound ((12 * div) + rem) | (DivBy prf) = abs rem + 1\n\nquiz : Stream Int -> (score : Nat) -> (questions : Nat) -> ConsoleIO (Nat, Nat)\nquiz (num1 :: num2 :: nums) score questions\n = do PutStr (\"Score so far: \" ++ show score ++ \" / \" ++ show questions ++ \"\\n\")\n PutStr (show num1 ++ \" * \" ++ show num2 ++ \"? \")\n answer <- GetLine\n if toLower answer == \"quit\" then Quit (score, questions) else\n if (cast answer == num1 * num2)\n then do PutStr \"Correct!\\n\"\n quiz nums (score + 1) (questions + 1)\n else do PutStr (\"Wrong, the answer is \" ++ show (num1 * num2) ++ \"\\n\")\n quiz nums score (questions + 1)\n\npartial\nforever : Fuel\nforever = More forever\n\npartial\nmain : IO ()\nmain = do seed <- time\n Just (score, qs) <- run forever (quiz (arithInputs (fromInteger seed)) 0 0)\n | Nothing => putStrLn \"Ran out of fuel\"\n putStrLn (\"Final score: \" ++ show score ++ \" / \" ++ show qs)\n\n" }, { "path": "Chapter11/Greet.idr", "content": "%default total\n\ndata InfIO : Type where\n Do : IO a -> (a -> Inf InfIO) -> InfIO\n\n(>>=) : IO a -> (a -> Inf InfIO) -> InfIO\n(>>=) = Do\n\ngreet : InfIO\ngreet = do putStr \"Enter your name: \"\n name <- getLine\n putStrLn (\"Hello \" ++ name)\n greet\n" }, { "path": "Chapter11/InfIO.idr", "content": "%default total\n\ndata InfIO : Type where\n Do : IO a -> (a -> Inf InfIO) -> InfIO\n\n(>>=) : IO a -> (a -> Inf InfIO) -> InfIO\n(>>=) = Do\n\nloopPrint : String -> InfIO\nloopPrint msg = do putStrLn msg\n loopPrint msg\n\ndata Fuel = Dry | More (Lazy Fuel)\n\ntank : Nat -> Fuel\ntank Z = Dry\ntank (S k) = More (tank k)\n\npartial\nrunPartial : InfIO -> IO ()\nrunPartial (Do action f) = do res <- action\n runPartial (f res)\n\nrun : Fuel -> InfIO -> IO ()\nrun (More fuel) (Do c f) = do res <- c\n run fuel (f res)\nrun Dry p = putStrLn \"Out of fuel\"\n\npartial\nforever : Fuel\nforever = More forever\n\npartial\nmain : IO ()\nmain = run (tank 10) (loopPrint \"vroom\")\n" }, { "path": "Chapter11/InfList.idr", "content": "data InfList : Type -> Type where\n (::) : (value : elem) -> Inf (InfList elem) -> InfList elem\n\n%name InfList xs, ys, zs\n\ncountFrom : Integer -> InfList Integer\ncountFrom x = x :: Delay (countFrom (x + 1))\n\ngetPrefix : (count : Nat) -> InfList a -> List a\ngetPrefix Z xs = []\ngetPrefix (S k) (value :: xs) = value :: getPrefix k xs\n\nlabelWith : InfList Integer -> List a -> List (Integer, a)\nlabelWith (lbl :: lbls) [] = []\nlabelWith (lbl :: lbls) (val :: vals) = (lbl, val) :: labelWith lbls vals\n\nlabel : List a -> List (Integer, a)\nlabel = labelWith (countFrom 0)\n" }, { "path": "Chapter11/Label.idr", "content": "\nlabelFrom : Integer -> List a -> List (Integer, a)\nlabelFrom lbl [] = []\nlabelFrom lbl (val :: vals) = (lbl, val) :: labelFrom (lbl + 1) vals\n\nlabel : List a -> List (Integer, a)\nlabel = labelFrom 0\n" }, { "path": "Chapter11/RunIO.idr", "content": "%default total\n\ndata RunIO : Type -> Type where\n Quit : a -> RunIO a\n Do : IO a -> (a -> Inf (RunIO b)) -> RunIO b\n\n(>>=) : IO a -> (a -> Inf (RunIO b)) -> RunIO b\n(>>=) = Do\n\ngreet : RunIO ()\ngreet = do putStr \"Enter your name: \"\n name <- getLine\n if name == \"\"\n then do putStrLn \"Bye bye!\"\n Quit ()\n else do putStrLn (\"Hello \" ++ name)\n greet\n\ndata Fuel = Dry | More (Lazy Fuel)\n\nrun : Fuel -> RunIO a -> IO (Maybe a)\nrun fuel (Quit val) = do pure (Just val)\nrun (More fuel) (Do c f) = do res <- c\n run fuel (f res)\nrun Dry p = pure Nothing\n\npartial\nforever : Fuel\nforever = More forever\n\npartial\nmain : IO ()\nmain = do run forever greet\n pure ()\n" }, { "path": "Chapter11/StreamFail.idr", "content": "countFrom : Integer -> List Integer\ncountFrom n = n :: countFrom (n + 1)\n\nlabelWith : List Integer -> List a -> List (Integer, a)\nlabelWith lbls [] = []\nlabelWith (lbl :: lbls) (val :: vals) = (lbl, val) :: labelWith lbls vals\n" }, { "path": "Chapter11/Streams.idr", "content": "labelWith : Stream labelType -> List a -> List (labelType, a)\nlabelWith lbls [] = []\nlabelWith (lbl :: lbls) (val :: vals) = (lbl, val) :: labelWith lbls vals\n\nlabel : List a -> List (Integer, a)\nlabel vals = labelWith (iterate (+1) 0) vals\n" }, { "path": "Chapter12/ArithState.idr", "content": "import Data.Primitives.Views\nimport System\n\n%default total\n\nrecord Score where\n constructor MkScore\n correct : Nat\n attempted : Nat\n\nrecord GameState where\n constructor MkGameState\n score : Score\n difficulty : Int\n\nShow GameState where\n show st = show (correct (score st)) ++ \"/\" ++\n show (attempted (score st)) ++ \"\\n\" ++\n \"Difficulty: \" ++ show (difficulty st)\n\ninitState : GameState\ninitState = MkGameState (MkScore 0 0) 12\n\naddWrong : GameState -> GameState\naddWrong = record { score->attempted $= (+1) }\n\naddCorrect : GameState -> GameState\naddCorrect = record { score->correct $= (+1),\n score->attempted $= (+1) }\n\nsetDifficulty : Int -> GameState -> GameState\nsetDifficulty newDiff state = record { difficulty = newDiff } state\n\ndata Command : Type -> Type where\n PutStr : String -> Command ()\n GetLine : Command String\n\n GetRandom : Command Int\n GetGameState : Command GameState\n PutGameState : GameState -> Command ()\n\n Pure : ty -> Command ty\n Bind : Command a -> (a -> Command b) -> Command b\n\ndata ConsoleIO : Type -> Type where\n Quit : a -> ConsoleIO a\n Do : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b\n\nnamespace ConsoleDo\n (>>=) : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b\n (>>=) = Do\n\nnamespace CommandDo\n (>>=) : Command a -> (a -> Command b) -> Command b\n (>>=) = Bind\n\nrandoms : Int -> Stream Int\nrandoms seed = let seed' = 1664525 * seed + 1013904223 in\n (seed' `shiftR` 2) :: randoms seed'\n\n\nrunCommand : Stream Int -> GameState -> Command a ->\n IO (a, Stream Int, GameState)\nrunCommand rnds state (PutStr x) = do putStr x\n pure ((), rnds, state)\nrunCommand rnds state GetLine = do str <- getLine\n pure (str, rnds, state)\n\nrunCommand (val :: rnds) state GetRandom\n = pure (getRandom val (difficulty state), rnds, state)\n where\n getRandom : Int -> Int -> Int\n getRandom val max with (divides val max)\n getRandom val 0 | DivByZero = 1\n getRandom ((max * div) + rem) max | (DivBy prf) = abs rem + 1\nrunCommand rnds state GetGameState\n = pure (state, rnds, state)\nrunCommand rnds state (PutGameState newState)\n = pure ((), rnds, newState)\n\nrunCommand rnds state (Pure val)\n = pure (val, rnds, state)\nrunCommand rnds state (Bind c f)\n = do (res, newRnds, newState) <- runCommand rnds state c\n runCommand newRnds newState (f res)\n\ndata Fuel = Dry | More (Lazy Fuel)\n\npartial\nforever : Fuel\nforever = More forever\n\nrun : Fuel -> Stream Int -> GameState -> ConsoleIO a ->\n IO (Maybe a, Stream Int, GameState)\nrun fuel rnds state (Quit val) = do pure (Just val, rnds, state)\nrun (More fuel) rnds state (Do c f)\n = do (res, newRnds, newState) <- runCommand rnds state c\n run fuel newRnds newState (f res)\nrun Dry rnds state p = pure (Nothing, rnds, state)\n\nmutual\n correct : ConsoleIO GameState\n correct = do PutStr \"Correct!\\n\"\n st <- GetGameState\n PutGameState (addCorrect st)\n quiz\n\n wrong : Int -> ConsoleIO GameState\n wrong ans\n = do PutStr (\"Wrong, the answer is \" ++ show ans ++ \"\\n\")\n st <- GetGameState\n PutGameState (addWrong st)\n quiz\n\n data Input = Answer Int\n | QuitCmd\n\n readInput : (prompt : String) -> Command Input\n readInput prompt\n = do PutStr prompt\n answer <- GetLine\n if toLower answer == \"quit\"\n then Pure QuitCmd\n else Pure (Answer (cast answer))\n\n quiz : ConsoleIO GameState\n quiz = do num1 <- GetRandom\n num2 <- GetRandom\n st <- GetGameState\n PutStr (show st ++ \"\\n\")\n\n input <- readInput (show num1 ++ \" * \" ++ show num2 ++ \"? \")\n case input of\n Answer answer => if answer == num1 * num2\n then correct\n else wrong (num1 * num2)\n QuitCmd => Quit st\n\npartial\nmain : IO ()\nmain = do seed <- time\n (Just score, _, state) <-\n run forever (randoms (fromInteger seed)) initState quiz\n | _ => putStrLn \"Ran out of fuel\"\n putStrLn (\"Final score: \" ++ show state)\n" }, { "path": "Chapter12/DataStore.idr", "content": "module Main\n\nimport Data.Vect\n\ninfixr 5 .+.\n\ndata Schema = SString | SInt | (.+.) Schema Schema\n\nSchemaType : Schema -> Type\nSchemaType SString = String\nSchemaType SInt = Int\nSchemaType (x .+. y) = (SchemaType x, SchemaType y)\n\nrecord DataStore (size : Nat) where\n constructor MkData\n schema : Schema\n items : Vect size (SchemaType schema)\n\nsetSchema : DataStore 0 -> Schema -> DataStore 0\nsetSchema (MkData schema []) schema' = MkData schema' []\n\ndata Command : Schema -> Type where\n SetSchema : Schema -> Command schema\n Add : SchemaType schema -> Command schema\n Get : Integer -> Command schema\n Quit : Command schema\n\n\n" }, { "path": "Chapter12/Exercises/ex_12_1.idr", "content": "import Control.Monad.State\n\ndata Tree a = Empty\n | Node (Tree a) a (Tree a)\n\ntestTree : Tree String\ntestTree = Node (Node (Node Empty \"Jim\" Empty) \"Fred\" \n (Node Empty \"Sheila\" Empty)) \"Alice\"\n (Node Empty \"Bob\" (Node Empty \"Eve\" Empty))\n\n{- 1 -}\n\nupdate : (stateType -> stateType) -> State stateType ()\nupdate f = do st <- get\n put (f st)\n\nincrement : Nat -> State Nat ()\nincrement x = update (+x)\n\n{- 2 -}\n\ncountEmpty : Tree a -> State Nat ()\ncountEmpty Empty = update (+1)\ncountEmpty (Node left val right) = do countEmpty left\n countEmpty right\n\n{- 3 -}\n\ncountEmptyNode : Tree a -> State (Nat, Nat) ()\ncountEmptyNode Empty = do (empty, nodes) <- get\n put (empty + 1, nodes)\ncountEmptyNode (Node left val right) = do countEmptyNode left\n (empty, nodes) <- get\n put (empty, nodes + 1)\n countEmptyNode right\n\n\n\n" }, { "path": "Chapter12/Exercises/ex_12_3a.idr", "content": "import Data.Primitives.Views\nimport System\n\n%default total\n\nrecord Score where\n constructor MkScore\n correct : Nat\n attempted : Nat\n\nrecord GameState where\n constructor MkGameState\n score : Score\n difficulty : Int\n\nShow GameState where\n show st = show (correct (score st)) ++ \"/\"\n ++ show (attempted (score st)) ++ \"\\n\"\n ++ \"Difficulty: \" ++ show (difficulty st)\n\ninitState : GameState\ninitState = MkGameState (MkScore 0 0) 12\n\naddWrong : GameState -> GameState\naddWrong = record { score->attempted $= (+1) }\n\naddCorrect : GameState -> GameState\naddCorrect = record { score->correct $= (+1),\n score->attempted $= (+1) }\n\nsetDifficulty : Int -> GameState -> GameState\nsetDifficulty newDiff state = record { difficulty = newDiff } state\n\ndata Command : Type -> Type where\n PutStr : String -> Command ()\n GetLine : Command String\n\n GetRandom : Command Int\n GetGameState : Command GameState\n PutGameState : GameState -> Command ()\n\n Pure : ty -> Command ty\n Bind : Command a -> (a -> Command b) -> Command b\n\ndata ConsoleIO : Type -> Type where\n Quit : a -> ConsoleIO a\n Do : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b\n\nnamespace ConsoleDo\n (>>=) : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b\n (>>=) = Do\n\n{- 2 -}\n\nmutual\n Functor Command where\n map func x = do x' <- x\n pure (func x')\n\n Applicative Command where\n pure = Pure \n (<*>) f a = do f' <- f\n a' <- a\n pure (f' a')\n\n Monad Command where\n (>>=) = Bind \n\nrandoms : Int -> Stream Int\nrandoms seed = let seed' = 1664525 * seed + 1013904223 in\n (seed' `shiftR` 2) :: randoms seed'\n\n\nrunCommand : Stream Int -> GameState -> Command a -> \n IO (a, Stream Int, GameState)\nrunCommand rnds state (PutStr x) = do putStr x\n pure ((), rnds, state)\nrunCommand rnds state GetLine = do str <- getLine\n pure (str, rnds, state)\n\nrunCommand (val :: rnds) state GetRandom\n = pure (getRandom val (difficulty state), rnds, state)\n where\n getRandom : Int -> Int -> Int\n getRandom val max with (divides val max)\n getRandom val 0 | DivByZero = 1\n getRandom ((max * div) + rem) max | (DivBy prf) = abs rem + 1\nrunCommand rnds state GetGameState \n = pure (state, rnds, state)\nrunCommand rnds state (PutGameState newState) \n = pure ((), rnds, newState)\n\nrunCommand rnds state (Pure val)\n = pure (val, rnds, state)\nrunCommand rnds state (Bind c f)\n = do (res, newRnds, newState) <- runCommand rnds state c\n runCommand newRnds newState (f res)\n\ndata Fuel = Dry | More (Lazy Fuel)\n\npartial\nforever : Fuel\nforever = More forever\n\nrun : Fuel -> Stream Int -> GameState -> ConsoleIO a -> \n IO (Maybe a, Stream Int, GameState)\nrun fuel rnds state (Quit val) = do pure (Just val, rnds, state)\nrun (More fuel) rnds state (Do c f) \n = do (res, newRnds, newState) <- runCommand rnds state c\n run fuel newRnds newState (f res)\nrun Dry rnds state p = pure (Nothing, rnds, state)\n\n{- 1 -}\n\nupdateGameState : (GameState -> GameState) -> Command ()\nupdateGameState f = do st <- GetGameState\n PutGameState (f st)\n\nmutual\n correct : ConsoleIO GameState\n correct = do PutStr \"Correct!\\n\"\n updateGameState addCorrect\n quiz \n\n wrong : Int -> ConsoleIO GameState\n wrong ans \n = do PutStr (\"Wrong, the answer is \" ++ show ans ++ \"\\n\")\n updateGameState addWrong\n quiz \n \n data Input = Answer Int\n | QuitCmd\n\n readInput : (prompt : String) -> Command Input\n readInput prompt \n = do PutStr prompt\n answer <- GetLine\n if toLower answer == \"quit\" \n then Pure QuitCmd \n else Pure (Answer (cast answer))\n\n quiz : ConsoleIO GameState\n quiz = do num1 <- GetRandom\n num2 <- GetRandom\n st <- GetGameState\n PutStr (show st ++ \"\\n\")\n\n input <- readInput (show num1 ++ \" * \" ++ show num2 ++ \"? \")\n case input of\n Answer answer => if answer == num1 * num2 \n then correct\n else wrong (num1 * num2) \n QuitCmd => Quit st\n\npartial\nmain : IO ()\nmain = do seed <- time\n (Just score, _, state) <- \n run forever (randoms (fromInteger seed)) initState quiz\n | _ => putStrLn \"Ran out of fuel\"\n putStrLn (\"Final score: \" ++ show state)\n" }, { "path": "Chapter12/Exercises/ex_12_3b.idr", "content": "\nrecord Votes where\n constructor MkVotes\n upvotes : Integer\n downvotes : Integer\n\nrecord Article where\n constructor MkArticle\n title : String\n url : String\n score : Votes\n\ninitPage : (title : String) -> (url : String) -> Article\ninitPage title url = MkArticle title url (MkVotes 0 0)\n\nbadSite : Article\nbadSite = MkArticle \"Bad Page\" \"http://example.com/bad\" (MkVotes 5 47)\n\ngoodSite : Article\ngoodSite = MkArticle \"Good Page\" \"http://example.com/good\" (MkVotes 101 7)\n\n{- 3 -}\n\ngetScore : Article -> Integer\ngetScore article = upvotes (score article) - downvotes (score article)\n\n{- 4 -}\n\naddUpvote : Article -> Article\naddUpvote = record { score->upvotes $= (+1) }\n\naddDownvote : Article -> Article\naddDownvote = record { score->downvotes $= (+1) }\n\n" }, { "path": "Chapter12/Record.idr", "content": "record Book where\n constructor MkBook\n title : String\n author : String\n\nrecord Album where\n constructor MkAlbum\n title : String\n tracks : List String\n\n" }, { "path": "Chapter12/State.idr", "content": "import Control.Monad.State\n\nincrement : Nat -> State Nat ()\nincrement inc = do current <- get\n put (current + inc)\n\n" }, { "path": "Chapter12/StateMonad.idr", "content": "data State : (stateType : Type) -> Type -> Type where\n Get : State stateType stateType\n Put : stateType -> State stateType ()\n\n Pure : ty -> State stateType ty\n Bind : State stateType a -> (a -> State stateType b) ->\n State stateType b\n\nget : State stateType stateType\nget = Get\n\nput : stateType -> State stateType ()\nput = Put\n\nmutual\n Functor (State stateType) where\n map func x = do val <- x\n pure (func val)\n\n Applicative (State stateType) where\n pure = Pure\n (<*>) f a = do f' <- f\n a' <- a\n pure (f' a')\n\n Monad (State stateType) where\n (>>=) = Bind\n\n{-\n(>>=) : State stateType a -> (a -> State stateType b) ->\n State stateType b\n(>>=) = Bind\n-}\n\nrunState : State stateType a -> (st : stateType) -> (a, stateType)\nrunState Get st = (st, st)\nrunState (Put newState) st = ((), newState)\n\nrunState (Pure x) st = (x, st)\nrunState (Bind cmd prog) st = let (val, nextState) = runState cmd st in\n runState (prog val) nextState\n\naddIfPositive : Integer -> State Integer Bool\naddIfPositive val = do when (val > 0) $\n do current <- get\n put (current + val)\n pure (val > 0)\n\naddPositives : List Integer -> State Integer Nat\naddPositives vals = do added <- traverse addIfPositive vals\n pure (length (filter id added))\n" }, { "path": "Chapter12/Traverse.idr", "content": "crew : List String\ncrew = [\"Lister\", \"Rimmer\", \"Kryten\", \"Cat\"]\n\nmain : IO ()\nmain = do putStr \"Display Crew? \"\n x <- getLine\n when (x == \"yes\") $ \n do traverse putStrLn crew\n pure ()\n putStrLn \"Done\"\n" }, { "path": "Chapter12/TreeLabel.idr", "content": "data Tree a = Empty\n | Node (Tree a) a (Tree a)\n\ntestTree : Tree String\ntestTree = Node (Node (Node Empty \"Jim\" Empty) \"Fred\" \n (Node Empty \"Sheila\" Empty)) \"Alice\"\n (Node Empty \"Bob\" (Node Empty \"Eve\" Empty))\n\nflatten : Tree a -> List a\nflatten Empty = []\nflatten (Node left val right) = flatten left ++ val :: flatten right\n\ntreeLabelWith : Stream labelType -> Tree a -> \n (Stream labelType, Tree (labelType, a))\ntreeLabelWith lbls Empty = (lbls, Empty)\ntreeLabelWith lbls (Node left val right) \n = let (this :: lblsLeft, left_labelled) = treeLabelWith lbls left\n (lblsRight, right_labelled) = treeLabelWith lblsLeft right\n in\n (lblsRight, Node left_labelled (this, val) right_labelled)\n\ntreeLabel : Tree a -> Tree (Integer, a)\ntreeLabel tree = snd (treeLabelWith [1..] tree)\n\n" }, { "path": "Chapter12/TreeLabelState.idr", "content": "import Control.Monad.State\n\ndata Tree a = Empty\n | Node (Tree a) a (Tree a)\n\ntestTree : Tree String\ntestTree = Node (Node (Node Empty \"Jim\" Empty) \"Fred\" \n (Node Empty \"Sheila\" Empty)) \"Alice\"\n (Node Empty \"Bob\" (Node Empty \"Eve\" Empty))\n\nflatten : Tree a -> List a\nflatten Empty = []\nflatten (Node left val right) = flatten left ++ val :: flatten right\n\ntreeLabelWith : Tree a -> State (Stream labelType) (Tree (labelType, a))\ntreeLabelWith Empty = pure Empty\ntreeLabelWith (Node left val right) \n = do left_labelled <- treeLabelWith left\n (this :: rest) <- get\n put rest\n right_labelled <- treeLabelWith right\n pure (Node left_labelled (this, val) right_labelled)\n\ntreeLabel : Tree a -> Tree (Integer, a)\ntreeLabel tree = evalState (treeLabelWith tree) [1..]\n\n" }, { "path": "Chapter12/TreeLabelType.idr", "content": "data Tree a = Empty\n | Node (Tree a) a (Tree a)\n\ntestTree : Tree String\ntestTree = Node (Node (Node Empty \"Jim\" Empty) \"Fred\" \n (Node Empty \"Sheila\" Empty)) \"Alice\"\n (Node Empty \"Bob\" (Node Empty \"Eve\" Empty))\n\nflatten : Tree a -> List a\nflatten Empty = []\nflatten (Node left val right) = flatten left ++ val :: flatten right\n\ndata State : (stateType : Type) -> Type -> Type where\n Get : State stateType stateType\n Put : stateType -> State stateType ()\n\n Pure : ty -> State stateType ty\n Bind : State stateType a -> (a -> State stateType b) -> \n State stateType b\n\n{-\n(>>=) : State stateType a -> (a -> State stateType b) -> \n State stateType b\n(>>=) = Bind\n-}\n\nmutual\n Functor (State stateType) where\n map func x = do val <- x\n Pure (func val)\n\n Applicative (State stateType) where\n pure x = Pure x\n (<*>) f a = do func <- f\n arg <- a\n pure (func arg)\n\n Monad (State stateType) where\n (>>=) = Bind\n\nrunState : State stateType a -> (st : stateType) -> (a, stateType)\nrunState Get st = (st, st)\nrunState (Put newState) st = ((), newState)\n\nrunState (Pure x) st = (x, st)\nrunState (Bind cmd prog) st = let (val, nextState) = runState cmd st in\n runState (prog val) nextState\n\ntreeLabelWith : Tree a -> State (Stream labelType) (Tree (labelType, a))\ntreeLabelWith Empty = Pure Empty\ntreeLabelWith (Node left val right) \n = do left_labelled <- treeLabelWith left\n (this :: rest) <- Get\n Put rest\n right_labelled <- treeLabelWith right\n Pure (Node left_labelled (this, val) right_labelled)\n\ntreeLabel : Tree a -> Tree (Integer, a)\ntreeLabel tree = fst (runState (treeLabelWith tree) [1..])\n\n" }, { "path": "Chapter13/Door.idr", "content": "data DoorState = DoorOpen | DoorClosed\n\ndata DoorCmd : Type -> DoorState -> DoorState -> Type where\n Open : DoorCmd () DoorClosed DoorOpen\n Close : DoorCmd () DoorOpen DoorClosed \n RingBell : DoorCmd () DoorClosed DoorClosed \n\n Pure : ty -> DoorCmd ty state state\n (>>=) : DoorCmd a state1 state2 ->\n (a -> DoorCmd b state2 state3) ->\n DoorCmd b state1 state3\n\ndoorProg : DoorCmd () DoorClosed DoorClosed\ndoorProg = do RingBell\n Open\n Close\n\n" }, { "path": "Chapter13/Exercises/ex_13_1.idr", "content": "namespace Q1\n\n data DoorState = DoorOpen | DoorClosed\n\n data DoorCmd : Type -> DoorState -> DoorState -> Type where\n Open : DoorCmd () DoorClosed DoorOpen\n Close : DoorCmd () DoorOpen DoorClosed\n RingBell : DoorCmd () state state\n\n Pure : ty -> DoorCmd ty state state\n (>>=) : DoorCmd a state1 state2 ->\n (a -> DoorCmd b state2 state3) ->\n DoorCmd b state1 state3\n\n doorProg : DoorCmd () DoorClosed DoorClosed\n doorProg = do RingBell\n Open\n RingBell\n Close\n\nnamespace Q2\n\n data GuessCmd : Type -> Nat -> Nat -> Type where\n Try : Integer -> GuessCmd Ordering (S guesses) guesses\n\n Pure : ty -> GuessCmd ty state state\n (>>=) : GuessCmd a state1 state2 ->\n (a -> GuessCmd b state2 state3) ->\n GuessCmd b state1 state3\n\n threeGuesses : GuessCmd () 3 0\n threeGuesses = do Try 10\n Try 20\n Try 15\n Pure ()\n\n {-\n no_guesses : GuessCmd () 0 0\n no_guesses = do Try 10\n Pure ()\n -}\n\nnamespace Q3\n\n data Matter = Solid | Liquid | Gas\n\n data MatterCmd : Type -> Matter -> Matter -> Type where\n Melt : MatterCmd () Solid Liquid\n Boil : MatterCmd () Liquid Gas\n\n Condense : MatterCmd () Gas Liquid\n Freeze : MatterCmd () Liquid Solid\n\n Pure : ty -> MatterCmd ty state state\n (>>=) : MatterCmd a state1 state2 ->\n (a -> MatterCmd b state2 state3) ->\n MatterCmd b state1 state3\n\n iceSteam : MatterCmd () Solid Gas\n iceSteam = do Melt\n Boil\n\n steamIce : MatterCmd () Gas Solid\n steamIce = do Condense\n Freeze\n\n{-\noverMelt : MatterCmd () Solid Gas\noverMelt = do Melt\n Melt\n -}\n" }, { "path": "Chapter13/Exercises/ex_13_2.idr", "content": "import Data.Vect\n\ndata StackCmd : Type -> Nat -> Nat -> Type where\n Push : Integer -> StackCmd () height (S height)\n Pop : StackCmd Integer (S height) height\n Top : StackCmd Integer (S height) (S height)\n\n GetStr : StackCmd String height height\n PutStr : String -> StackCmd () height height\n\n Pure : ty -> StackCmd ty height height\n (>>=) : StackCmd a height1 height2 ->\n (a -> StackCmd b height2 height3) ->\n StackCmd b height1 height3\n\nrunStack : (stk : Vect inHeight Integer) ->\n StackCmd ty inHeight outHeight -> IO (ty, Vect outHeight Integer)\nrunStack stk (Push val) = pure ((), val :: stk)\nrunStack (val :: stk) Pop = pure (val, stk)\nrunStack (val :: stk) Top = pure (val, val :: stk)\nrunStack stk GetStr = do x <- getLine\n pure (x, stk)\nrunStack stk (PutStr x) = do putStr x\n pure ((), stk)\nrunStack stk (Pure x) = pure (x, stk)\nrunStack stk (x >>= f) = do (x', newStk) <- runStack stk x\n runStack newStk (f x')\n\ndata StackIO : Nat -> Type where\n Do : StackCmd a height1 height2 -> \n (a -> Inf (StackIO height2)) -> StackIO height1\n\nnamespace StackDo\n (>>=) : StackCmd a height1 height2 -> \n (a -> Inf (StackIO height2)) -> StackIO height1\n (>>=) = Do\n\ndata Fuel = Dry | More (Lazy Fuel)\n\npartial\nforever : Fuel\nforever = More forever\n\nrun : Fuel -> Vect height Integer -> StackIO height -> IO ()\nrun (More fuel) stk (Do c f) \n = do (res, newStk) <- runStack stk c\n run fuel newStk (f res)\nrun Dry stk p = pure ()\n\ndoAdd : StackCmd () (S (S height)) (S height)\ndoAdd = do val1 <- Pop\n val2 <- Pop\n Push (val1 + val2)\n\ndoSub : StackCmd () (S (S height)) (S height)\ndoSub = do val1 <- Pop\n val2 <- Pop\n Push (val2 - val1)\n\ndoMul : StackCmd () (S (S height)) (S height)\ndoMul = do val1 <- Pop\n val2 <- Pop\n Push (val1 * val2)\n\nmutual\n tryAdd : StackIO height\n tryAdd {height = (S (S h))} = do doAdd\n result <- Top\n PutStr (show result ++ \"\\n\")\n stackCalc\n tryAdd = do PutStr \"Fewer than two items on the stack\\n\"\n stackCalc\n\n trySub : StackIO height\n trySub {height = (S (S h))} = do doSub\n result <- Top\n PutStr (show result ++ \"\\n\")\n stackCalc\n trySub = do PutStr \"Fewer than two items on the stack\\n\"\n stackCalc\n\n tryMul : StackIO height\n tryMul {height = (S (S h))} = do doMul\n result <- Top\n PutStr (show result ++ \"\\n\")\n stackCalc\n tryMul = do PutStr \"Fewer than two items on the stack\\n\"\n stackCalc\n\n tryNeg : StackIO height\n tryNeg {height = (S h)} = do x <- Pop\n Push (-x)\n result <- Top\n PutStr (show result ++ \"\\n\")\n stackCalc\n tryNeg = do PutStr \"Nothing on the stack\\n\"\n stackCalc\n \n tryDup : StackIO height\n tryDup {height = (S h)} = do x <- Top\n Push x\n PutStr (\"Duplicated \" ++ show x ++ \"\\n\")\n stackCalc\n tryDup = do PutStr \"Nothing on the stack\\n\"\n stackCalc\n\n tryDiscard : StackIO height\n tryDiscard {height = (S h)} = do x <- Pop\n PutStr (\"Discarded \" ++ show x ++ \"\\n\")\n stackCalc\n tryDiscard = do PutStr \"Nothing on the stack\\n\"\n stackCalc\n\n data StkInput = Number Integer\n | Add\n | Subtract\n | Multiply\n | Negate\n | Discard\n | Duplicate\n\n strToInput : String -> Maybe StkInput\n strToInput \"add\" = Just Add\n strToInput \"subtract\" = Just Subtract\n strToInput \"multiply\" = Just Multiply\n strToInput \"negate\" = Just Negate\n strToInput \"discard\" = Just Discard\n strToInput \"duplicate\" = Just Duplicate\n strToInput x = if all isDigit (unpack x) \n then Just (Number (cast x))\n else Nothing\n\n stackCalc : StackIO height\n stackCalc = do PutStr \"> \"\n input <- GetStr\n case strToInput input of\n Nothing => do PutStr \"Invalid input\\n\"\n stackCalc\n Just (Number x) => do Push x\n stackCalc\n Just Add => tryAdd\n Just Subtract => trySub\n Just Multiply => tryMul\n Just Negate => tryNeg\n Just Discard => tryDiscard\n Just Duplicate => tryDup\n\nmain : IO ()\nmain = run forever [] stackCalc\n\n" }, { "path": "Chapter13/Stack.idr", "content": "import Data.Vect\n\ndata StackCmd : Type -> Nat -> Nat -> Type where\n Push : Integer -> StackCmd () height (S height)\n Pop : StackCmd Integer (S height) height\n Top : StackCmd Integer (S height) (S height)\n\n Pure : ty -> StackCmd ty height height\n (>>=) : StackCmd a height1 height2 ->\n (a -> StackCmd b height2 height3) ->\n StackCmd b height1 height3\n\nrunStack : (stk : Vect inHeight Integer) ->\n StackCmd ty inHeight outHeight -> \n (ty, Vect outHeight Integer)\nrunStack stk (Push val) = ((), val :: stk)\nrunStack (val :: stk) Pop = (val, stk)\nrunStack (val :: stk) Top = (val, val :: stk)\nrunStack stk (Pure x) = (x, stk)\nrunStack stk (x >>= f) = let (x', newStk) = runStack stk x in\n runStack newStk (f x')\n\ntestAdd : StackCmd Integer 0 0\ntestAdd = do Push 10\n-- Push 20\n val1 <- Pop\n val2 <- Pop\n Pure (val1 + val2)\n\ndoAdd : StackCmd () (S (S height)) (S height)\ndoAdd = do val1 <- Pop\n val2 <- Pop\n Push (val1 + val2)\n\n" }, { "path": "Chapter13/StackIO.idr", "content": "import Data.Vect\n\ndata StackCmd : Type -> Nat -> Nat -> Type where\n Push : Integer -> StackCmd () height (S height)\n Pop : StackCmd Integer (S height) height\n Top : StackCmd Integer (S height) (S height)\n\n GetStr : StackCmd String height height\n PutStr : String -> StackCmd () height height\n\n Pure : ty -> StackCmd ty height height\n (>>=) : StackCmd a height1 height2 ->\n (a -> StackCmd b height2 height3) ->\n StackCmd b height1 height3\n\nrunStack : (stk : Vect inHeight Integer) ->\n StackCmd ty inHeight outHeight -> IO (ty, Vect outHeight Integer)\nrunStack stk (Push val) = pure ((), val :: stk)\nrunStack (val :: stk) Pop = pure (val, stk)\nrunStack (val :: stk) Top = pure (val, val :: stk)\nrunStack stk GetStr = do x <- getLine\n pure (x, stk)\nrunStack stk (PutStr x) = do putStr x\n pure ((), stk)\nrunStack stk (Pure x) = pure (x, stk)\nrunStack stk (x >>= f) = do (x', newStk) <- runStack stk x\n runStack newStk (f x')\n\ntestAdd : StackCmd () 0 0\ntestAdd = do Push 10\n x <- GetStr\n Push (cast x)\n val1 <- Pop\n val2 <- Pop\n PutStr (show (val1 + val2) ++ \"\\n\")\n\ndata StackIO : Nat -> Type where\n Do : StackCmd a height1 height2 -> \n (a -> Inf (StackIO height2)) -> StackIO height1\n\nnamespace StackDo\n (>>=) : StackCmd a height1 height2 -> \n (a -> Inf (StackIO height2)) -> StackIO height1\n (>>=) = Do\n\ndata Fuel = Dry | More (Lazy Fuel)\n\npartial\nforever : Fuel\nforever = More forever\n\nrun : Fuel -> Vect height Integer -> StackIO height -> IO ()\nrun (More fuel) stk (Do c f) \n = do (res, newStk) <- runStack stk c\n run fuel newStk (f res)\nrun Dry stk p = pure ()\n\ndoAdd : StackCmd () (S (S height)) (S height)\ndoAdd = do val1 <- Pop\n val2 <- Pop\n Push (val1 + val2)\n\nmutual\n tryAdd : StackIO height\n tryAdd {height = (S (S h))} = do doAdd\n result <- Top\n PutStr (show result ++ \"\\n\")\n stackCalc\n tryAdd = do PutStr \"Fewer than two items on the stack\\n\"\n stackCalc\n\n data StkInput = Number Integer\n | Add\n\n strToInput : String -> Maybe StkInput\n strToInput \"\" = Nothing \n strToInput \"add\" = Just Add\n strToInput x = if all isDigit (unpack x) \n then Just (Number (cast x))\n else Nothing\n\n stackCalc : StackIO height\n stackCalc = do PutStr \"> \"\n input <- GetStr\n case strToInput input of\n Nothing => do PutStr \"Invalid input\\n\"\n stackCalc\n Just (Number x) => do Push x\n stackCalc\n Just Add => tryAdd\n\nmain : IO ()\nmain = run forever [] stackCalc\n\n" }, { "path": "Chapter13/Vending.idr", "content": "VendState : Type\nVendState = (Nat, Nat)\n\ndata Input = COIN \n | VEND \n | CHANGE \n | REFILL Nat\n\nstrToInput : String -> Maybe Input\nstrToInput \"insert\" = Just COIN\nstrToInput \"vend\" = Just VEND\nstrToInput \"change\" = Just CHANGE\nstrToInput x = if all isDigit (unpack x)\n then Just (REFILL (cast x))\n else Nothing\n\ndata MachineCmd : Type -> VendState -> VendState -> Type where\n InsertCoin : MachineCmd () (pounds, chocs) (S pounds, chocs)\n Vend : MachineCmd () (S pounds, S chocs) (pounds, chocs)\n GetCoins : MachineCmd () (pounds, chocs) (Z, chocs)\n\n Display : String -> \n MachineCmd () state state\n Refill : (bars : Nat) -> \n MachineCmd () (Z, chocs) (Z, bars + chocs)\n\n GetInput : MachineCmd (Maybe Input) state state \n\n Pure : ty -> MachineCmd ty state state\n (>>=) : MachineCmd a state1 state2 -> (a -> MachineCmd b state2 state3) ->\n MachineCmd b state1 state3\n\ndata MachineIO : VendState -> Type where\n Do : MachineCmd a state1 state2 ->\n (a -> Inf (MachineIO state2)) -> MachineIO state1\n\nrunMachine : MachineCmd ty inState outState -> IO ty\nrunMachine InsertCoin = putStrLn \"Coin inserted\"\nrunMachine Vend = putStrLn \"Please take your chocolate\"\nrunMachine {inState = (pounds, _)} GetCoins \n = putStrLn (show pounds ++ \" coins returned\")\nrunMachine (Display str) = putStrLn str\nrunMachine (Refill bars)\n = putStrLn (\"Chocolate remaining: \" ++ show bars)\nrunMachine {inState = (pounds, chocs)} GetInput\n = do putStrLn (\"Coins: \" ++ show pounds ++ \"; \" ++\n \"Stock: \" ++ show chocs)\n putStr \"> \"\n x <- getLine\n pure (strToInput x)\nrunMachine (Pure x) = pure x\nrunMachine (cmd >>= prog) = do x <- runMachine cmd\n runMachine (prog x)\n\ndata Fuel = Dry | More (Lazy Fuel)\n\npartial\nforever : Fuel\nforever = More forever\n\nrun : Fuel -> MachineIO state -> IO ()\nrun (More fuel) (Do c f) \n = do res <- runMachine c\n run fuel (f res)\nrun Dry p = pure ()\n\n\nnamespace MachineDo\n (>>=) : MachineCmd a state1 state2 ->\n (a -> Inf (MachineIO state2)) -> MachineIO state1\n (>>=) = Do\n\nmutual\n vend : MachineIO (pounds, chocs)\n vend {pounds = S p} {chocs = S c} = do Vend\n Display \"Enjoy!\"\n machineLoop\n vend {pounds = Z} = do Display \"Insert a coin\"\n machineLoop\n vend {chocs = Z} = do Display \"Out of stock\"\n machineLoop\n\n refill : (num : Nat) -> MachineIO (pounds, chocs)\n refill {pounds = Z} num = do Refill num\n machineLoop\n refill _ = do Display \"Can't refill: Coins in machine\"\n machineLoop\n\n machineLoop : MachineIO (pounds, chocs)\n machineLoop =\n do Just x <- GetInput | Nothig => do Display \"Invalid input\"\n machineLoop\n case x of\n COIN => do InsertCoin\n machineLoop\n VEND => vend\n CHANGE => do GetCoins\n Display \"Change returned\"\n machineLoop\n REFILL num => refill num\n\nmain : IO ()\nmain = run forever (machineLoop {pounds = 0} {chocs = 1})\n\n" }, { "path": "Chapter14/ATM.idr", "content": "import Data.Vect\n\ndata ATMState = Ready | CardInserted | Session\ndata PINCheck = CorrectPIN | IncorrectPIN\n\nPIN : Type\nPIN = Vect 4 Char\n\ndata HasCard : ATMState -> Type where\n HasCI : HasCard CardInserted\n HasSession : HasCard Session\n\ndata ATMCmd : (res : Type) -> ATMState -> (res -> ATMState) -> Type where\n InsertCard : ATMCmd () Ready (const CardInserted)\n EjectCard : {auto prf : HasCard state} ->\n ATMCmd () state (const Ready)\n GetPIN : ATMCmd PIN CardInserted (const CardInserted) \n\n CheckPIN : PIN -> ATMCmd PINCheck CardInserted \n (\\check => case check of\n CorrectPIN => Session\n IncorrectPIN => CardInserted)\n GetAmount : ATMCmd Nat state (const state)\n\n Dispense : (amount : Nat) -> ATMCmd () Session (const Session)\n\n Message : String -> ATMCmd () state (const state)\n Pure : (res : ty) -> ATMCmd ty (state_fn res) state_fn\n (>>=) : ATMCmd a state1 state2_fn ->\n ((res : a) -> ATMCmd b (state2_fn res) state3_fn) ->\n ATMCmd b state1 state3_fn\n\nreadVect : (n : Nat) -> IO (Vect n Char)\nreadVect Z = do discard <- getLine -- rest of input up to enter\n pure []\nreadVect (S k) = do ch <- getChar\n chs <- readVect k\n pure (ch :: chs)\n\ntestPIN : Vect 4 Char\ntestPIN = ['1', '2', '3', '4']\n\ninsertEject : ATMCmd () Ready (const Ready)\ninsertEject = do InsertCard\n EjectCard -- ?insertEject_rhs\n\n-- badATM : ATMCmd () Ready (const Ready)\n-- badATM = EjectCard\n\nrunATM : ATMCmd res instate outstate_fn -> IO res\nrunATM InsertCard = do putStrLn \"Please insert your card (press enter)\"\n x <- getLine\n pure ()\nrunATM EjectCard = putStrLn \"Card ejected\"\nrunATM GetPIN = do putStr \"Enter PIN: \"\n readVect 4\nrunATM (CheckPIN pin) = if pin == testPIN\n then pure CorrectPIN\n else pure IncorrectPIN\nrunATM GetAmount = do putStr \"How much would you like? \"\n x <- getLine\n pure (cast x)\nrunATM (Dispense amount) = putStrLn (\"Here is \" ++ show amount)\nrunATM (Message msg) = putStrLn msg\nrunATM (Pure res) = pure res\nrunATM (x >>= f) = do x' <- runATM x\n runATM (f x')\n\natm : ATMCmd () Ready (const Ready)\natm = do InsertCard\n pin <- GetPIN\n pinOK <- CheckPIN pin\n case pinOK of\n CorrectPIN => do cash <- GetAmount\n Dispense cash\n EjectCard\n IncorrectPIN => EjectCard\n\natm_alt : ATMCmd () Ready (const Ready)\natm_alt = do InsertCard\n pin <- GetPIN\n cash <- GetAmount\n pinOK <- CheckPIN pin\n Message \"Checking Card\"\n case pinOK of\n CorrectPIN => do Dispense cash\n EjectCard\n Message \"Please remove your card and cash\"\n IncorrectPIN => do Message \"Incorrect PIN\"\n EjectCard\n\n\n" }, { "path": "Chapter14/DoorJam.idr", "content": "data DoorState = DoorOpen | DoorClosed\n\ndata DoorResult = OK | Jammed\n\ndata DoorCmd : (ty : Type) -> DoorState -> (ty -> DoorState) -> Type where\n Open : DoorCmd DoorResult DoorClosed \n (\\res => case res of\n OK => DoorOpen\n Jammed => DoorClosed)\n Close : DoorCmd () DoorOpen (const DoorClosed)\n RingBell : DoorCmd () DoorClosed (const DoorClosed)\n\n Display : String -> DoorCmd () state (const state)\n\n Pure : (res : ty) -> DoorCmd ty (state_fn res) state_fn\n (>>=) : DoorCmd a state1 state2_fn ->\n ((res : a) -> DoorCmd b (state2_fn res) state3_fn) ->\n DoorCmd b state1 state3_fn\n\nlogOpen : DoorCmd DoorResult DoorClosed \n (\\res => case res of\n OK => DoorOpen\n Jammed => DoorClosed)\nlogOpen = do Display \"Trying to open the door\"\n OK <- Open | Jammed => do Display \"Jammed\"\n Pure Jammed\n Display \"Success\"\n Pure OK\n\ndoorProg : DoorCmd () DoorClosed (const DoorClosed)\ndoorProg = do RingBell\n jam <- Open\n Display \"Trying to open the door\"\n case jam of\n OK => do Display \"Glad To Be Of Service\"\n Close\n Jammed => Display \"Door Jammed\"\n\ndoorProg2 : DoorCmd () DoorClosed (const DoorClosed)\ndoorProg2 = do RingBell\n OK <- Open | Jammed => Display \"Door Jammed\"\n Display \"Glad To Be Of Service\"\n Close\n OK <- Open | Jammed => Display \"Door Jammed\"\n Display \"Glad To Be Of Service\"\n Close\n" }, { "path": "Chapter14/Exercises/ex_14_2_1.idr", "content": "data Access = LoggedOut | LoggedIn\ndata PwdCheck = Correct | Incorrect\n\ndata ShellCmd : (ty : Type) -> Access -> (ty -> Access) -> Type where\n Password : String -> ShellCmd PwdCheck LoggedOut\n (\\res => case res of\n Correct => LoggedIn\n Incorrect => LoggedOut)\n Logout : ShellCmd () LoggedIn (const LoggedOut)\n GetSecret : ShellCmd String LoggedIn (const LoggedIn)\n\n PutStr : String -> ShellCmd () state (const state)\n\n Pure : (res : ty) -> ShellCmd ty (state_fn res) state_fn\n (>>=) : ShellCmd a state1 state2_fn ->\n ((res : a) -> ShellCmd b (state2_fn res) state3_fn) ->\n ShellCmd b state1 state3_fn\n\nsession : ShellCmd () LoggedOut (const LoggedOut)\nsession = do Correct <- Password \"wurzel\"\n | Incorrect => PutStr \"Wrong password\"\n msg <- GetSecret\n PutStr (\"Secret code: \" ++ show msg ++ \"\\n\")\n Logout\n\n{-\nbadSession : ShellCmd () LoggedOut (const LoggedOut)\nbadSession = do Password \"wurzel\"\n msg <- GetSecret\n PutStr (\"Secret code: \" ++ show msg ++ \"\\n\")\n Logout\n\nnoLogout : ShellCmd () LoggedOut (const LoggedOut)\nnoLogout = do Correct <- Password \"wurzel\"\n | Incorrect => PutStr \"Wrong password\"\n msg <- GetSecret\n PutStr (\"Secret code: \" ++ show msg ++ \"\\n\")\n-}\n" }, { "path": "Chapter14/Exercises/ex_14_2_2.idr", "content": "VendState : Type\nVendState = (Nat, Nat)\n\ndata Input = COIN \n | VEND \n | CHANGE \n | REFILL Nat\n\nstrToInput : String -> Maybe Input\nstrToInput \"insert\" = Just COIN\nstrToInput \"vend\" = Just VEND\nstrToInput \"change\" = Just CHANGE\nstrToInput x = if all isDigit (unpack x)\n then Just (REFILL (cast x))\n else Nothing\n\ndata CoinResult = Inserted | Rejected\n\ndata MachineCmd : (res : Type) -> VendState -> (res -> VendState) -> Type where\n InsertCoin : MachineCmd CoinResult (pounds, chocs) \n (\\res => case res of\n Inserted => (S pounds, chocs)\n Rejected => (pounds, chocs))\n Vend : MachineCmd () (S pounds, S chocs) (const (pounds, chocs))\n GetCoins : MachineCmd () (pounds, chocs) (const (Z, chocs))\n\n Display : String -> \n MachineCmd () state (const state)\n Refill : (bars : Nat) -> \n MachineCmd () (Z, chocs) (const (Z, bars + chocs))\n\n GetInput : MachineCmd (Maybe Input) state (const state)\n\n Pure : (res : ty) -> MachineCmd ty (state_fn res) state_fn\n (>>=) : MachineCmd a state1 state2_fn -> \n ((x : a) -> MachineCmd b (state2_fn x) state3_fn) ->\n MachineCmd b state1 state3_fn\n\ndata MachineIO : VendState -> Type where\n Do : MachineCmd a state1 state2_fn ->\n ((x : a) -> Inf (MachineIO (state2_fn x))) -> MachineIO state1\n \nnamespace MachineDo\n (>>=) : MachineCmd a state1 state2_fn ->\n ((x : a) -> Inf (MachineIO (state2_fn x))) -> MachineIO state1\n (>>=) = Do\n\nmutual\n vend : MachineIO (pounds, chocs)\n vend {pounds = S p} {chocs = S c} = do Vend\n Display \"Enjoy!\"\n machineLoop\n vend {pounds = Z} = do Display \"Insert a coin\"\n machineLoop\n vend {chocs = Z} = do Display \"Out of stock\"\n machineLoop\n\n refill : (num : Nat) -> MachineIO (pounds, chocs)\n refill {pounds = Z} num = do Refill num\n machineLoop\n refill _ = do Display \"Can't refill: Coins in machine\"\n machineLoop\n\n machineLoop : MachineIO (pounds, chocs)\n machineLoop =\n do Just x <- GetInput | Nothig => do Display \"Invalid input\"\n machineLoop\n case x of\n COIN => do res <- InsertCoin\n case res of\n Inserted => do Display \"Coin inserted\"\n machineLoop\n Rejected => do Display \"Coin rejected\"\n machineLoop\n VEND => vend\n CHANGE => do GetCoins\n Display \"Change returned\"\n machineLoop\n REFILL num => refill num\n\n" }, { "path": "Chapter14/Hangman.idr", "content": "import Data.Vect\n\n%default total\n\ndata GameState : Type where\n NotRunning : GameState\n Running : (guesses : Nat) -> (letters : Nat) -> GameState\n\nletters : String -> List Char\nletters str = nub (map toUpper (unpack str))\n\ndata GuessResult = Correct | Incorrect\n\ndata GameCmd : (ty : Type) -> GameState -> (ty -> GameState) -> Type where\n\n NewGame : (word : String) ->\n GameCmd ()\n NotRunning\n (const (Running 6 (length (letters word))))\n\n Won : GameCmd () (Running (S guesses) 0)\n (const NotRunning)\n Lost : GameCmd () (Running 0 (S guesses))\n (const NotRunning)\n\n Guess : (c : Char) ->\n GameCmd GuessResult\n (Running (S guesses) (S letters))\n (\\res => case res of\n Correct => Running (S guesses) letters\n Incorrect => Running guesses (S letters))\n\n\n ShowState : GameCmd () state (const state)\n Message : String -> GameCmd () state (const state)\n ReadGuess : GameCmd Char state (const state)\n\n Pure : (res : ty) -> GameCmd ty (state_fn res) state_fn\n (>>=) : GameCmd a state1 state2_fn ->\n ((res : a) -> GameCmd b (state2_fn res) state3_fn) ->\n GameCmd b state1 state3_fn\n\nnamespace Loop\n data GameLoop : (ty : Type) -> GameState -> (ty -> GameState) -> Type where\n (>>=) : GameCmd a state1 state2_fn ->\n ((res : a) -> Inf (GameLoop b (state2_fn res) state3_fn)) ->\n GameLoop b state1 state3_fn\n Exit : GameLoop () NotRunning (const NotRunning)\n\ngameLoop : GameLoop () (Running (S guesses) (S letters)) (const NotRunning)\ngameLoop {guesses} {letters} = do\n ShowState\n g <- ReadGuess\n ok <- Guess g\n case ok of\n Correct => case letters of\n Z => do Won\n ShowState\n Exit\n S k => do Message \"Correct\"\n gameLoop\n Incorrect => case guesses of\n Z => do Lost\n ShowState\n Exit\n (S k) => do Message \"Incorrect\"\n gameLoop\n\nhangman : GameLoop () NotRunning (const NotRunning)\nhangman = do NewGame \"testing\"\n gameLoop\n\ndata Game : GameState -> Type where\n GameStart : Game NotRunning\n GameWon : (word : String) -> Game NotRunning\n GameLost : (word : String) -> Game NotRunning\n InProgress : (word : String) -> (guesses : Nat)\n -> (missing : Vect letters Char)\n -> Game (Running guesses letters)\n\nShow (Game g) where\n show GameStart = \"Starting\"\n show (GameWon word) = \"Game won: word was \" ++ word\n show (GameLost word) = \"Game lost: word was \" ++ word\n show (InProgress word guesses missing)\n = \"\\n\" ++ pack (map hideMissing (unpack word))\n ++ \"\\n\" ++ show guesses ++ \" guesses left\"\n where hideMissing : Char -> Char\n hideMissing c = if c `elem` missing then '-' else c\n\ndata Fuel = Dry | More (Lazy Fuel)\n\ntotal\nremoveElem : (value : a) -> (xs : Vect (S n) a) ->\n {auto prf : Elem value xs} ->\n Vect n a\nremoveElem value (value :: ys) {prf = Here} = ys\nremoveElem {n = Z} value (y :: []) {prf = There later} = absurd later\nremoveElem {n = (S k)} value (y :: ys) {prf = There later}\n = y :: removeElem value ys\n\ndata GameResult : (ty : Type) -> (ty -> GameState) -> Type where\n OK : (res : ty) -> Game (outstate_fn res) ->\n GameResult ty outstate_fn\n OutOfFuel : GameResult ty outstate_fn\n\nok : (res : ty) -> Game (outstate_fn res) ->\n IO (GameResult ty outstate_fn)\nok res st = pure (OK res st)\n\nrunCmd : Fuel -> Game instate -> GameCmd ty instate outstate_fn ->\n IO (GameResult ty outstate_fn)\nrunCmd fuel state (NewGame word)\n = ok () (InProgress (toUpper word) _ (fromList (letters word)))\nrunCmd fuel (InProgress word _ missing) Won = ok () (GameWon word)\nrunCmd fuel (InProgress word _ missing) Lost = ok () (GameLost word)\n\nrunCmd fuel (InProgress word _ missing) (Guess c)\n = case isElem c missing of\n Yes prf => ok Correct (InProgress word _ (removeElem c missing))\n No contra => ok Incorrect (InProgress word _ missing)\n\nrunCmd fuel state ShowState = do printLn state\n ok () state\nrunCmd fuel state (Message str) = do putStrLn str\n ok () state\nrunCmd (More fuel) st ReadGuess = do\n putStr \"Guess: \"\n input <- getLine\n case unpack input of\n [x] => if isAlpha x\n then ok (toUpper x) st\n else do putStrLn \"Invalid input\"\n runCmd fuel st ReadGuess\n _ => do putStrLn \"Invalid input\"\n runCmd fuel st ReadGuess\n\nrunCmd fuel state (Pure res) = ok res state\nrunCmd fuel st (cmd >>= next) = do OK cmdRes newSt <- runCmd fuel st cmd\n | OutOfFuel => pure OutOfFuel\n runCmd fuel newSt (next cmdRes)\nrunCmd Dry _ _ = pure OutOfFuel\n\nrun : Fuel -> Game instate -> GameLoop ty instate outstate_fn ->\n IO (GameResult ty outstate_fn)\nrun Dry _ _ = pure OutOfFuel\nrun (More fuel) st (cmd >>= next)\n = do OK cmdRes newSt <- runCmd fuel st cmd\n | OutOfFuel => pure OutOfFuel\n run fuel newSt (next cmdRes)\nrun (More fuel) st Exit = pure (OK () st)\n\n%default partial\n\nforever : Fuel\nforever = More forever\n\nmain : IO ()\nmain = do run forever GameStart hangman\n pure ()\n" }, { "path": "Chapter15/AdderChannel.idr", "content": "import System.Concurrency.Channels\n\ndata Message = Add Nat Nat\n\nadder : IO ()\nadder = do Just sender_chan <- listen 1\n | Nothing => adder\n Just msg <- unsafeRecv Message sender_chan\n | Nothing => adder\n case msg of\n Add x y => do ok <- unsafeSend sender_chan (x + y)\n adder\n\nmain : IO ()\nmain = do Just adder_id <- spawn adder\n | Nothing => putStrLn \"Spawn failed\"\n Just chan <- connect adder_id\n | Nothing => putStrLn \"Connection failed\"\n ok <- unsafeSend chan (Add 2 3)\n Just answer <- unsafeRecv String chan\n | Nothing => putStrLn \"Send failed\"\n printLn answer\n" }, { "path": "Chapter15/ListProc.idr", "content": "import ProcessLib\n\ndata ListAction : Type where\n Length : List elem -> ListAction\n Append : List elem -> List elem -> ListAction\n\nListType : ListAction -> Type\nListType (Length xs) = Nat\nListType (Append {elem} xs ys) = List elem\n\ntotal\nprocList : Service ListType ()\nprocList = do Respond (\\msg => case msg of\n Length xs => Pure (length xs)\n Append xs ys => Pure (xs ++ ys))\n Loop procList\n\nprocMain : Client ()\nprocMain = do Just list <- Spawn procList\n | Nothing => Action (putStrLn \"Spawn failed\")\n len <- Request list (Length [1,2,3])\n Action (printLn len)\n\n app <- Request list (Append [1,2,3] [4,5,6])\n Action (printLn app)\n" }, { "path": "Chapter15/Process.idr", "content": "import System.Concurrency.Channels\n\ndata Message = Add Nat Nat\n\ndata MessagePID = MkMessage PID\n\ndata Process : Type -> Type where\n Request : MessagePID -> Message -> Process (Maybe Nat)\n Respond : ((msg : Message) -> Process Nat) -> Process (Maybe Message)\n Spawn : Process () -> Process (Maybe MessagePID)\n Loop : Inf (Process a) -> Process a\n\n Action : IO a -> Process a\n Pure : a -> Process a\n (>>=) : Process a -> (a -> Process b) -> Process b\n\nrun : Process t -> IO t\nrun (Request (MkMessage process) msg)\n = do Just chan <- connect process\n | _ => pure Nothing\n ok <- unsafeSend chan msg\n if ok then do Just x <- unsafeRecv Nat chan\n | Nothing => pure Nothing\n pure (Just x)\n else pure Nothing\nrun (Respond calc)\n = do Just sender <- listen 1\n | Nothing => pure Nothing -- No incoming connections\n Just msg <- unsafeRecv Message sender\n | Nothing => pure Nothing -- no message received\n res <- run (calc msg)\n unsafeSend sender res\n pure (Just msg)\nrun (Spawn proc) = do Just pid <- spawn (run proc)\n | Nothing => pure Nothing\n pure (Just (MkMessage pid))\nrun (Loop action) = run action\nrun (Action act) = act\nrun (Pure val) = pure val\nrun (act >>= next) = do x <- run act\n run (next x)\n\nprocAdder : Process ()\nprocAdder = do Respond (\\msg => case msg of\n Add x y => Pure (x + y))\n procAdder\n\nprocMain : Process ()\nprocMain = do Just adder_id <- Spawn procAdder\n | Nothing => Action (putStrLn \"Spawn failed\")\n Just answer <- Request adder_id (Add 2 3)\n | Nothing => Action (putStrLn \"Request failed\")\n Action (printLn answer)\n" }, { "path": "Chapter15/ProcessIFace.idr", "content": "import System.Concurrency.Channels\n\ndata Message = Add Nat Nat\n\nAdderType : Message -> Type\nAdderType (Add x y) = Nat\n\ndata ListAction : Type where\n Length : List a -> ListAction\n Append : List a -> List a -> ListAction\n\nListType : ListAction -> Type\nListType (Length xs) = Nat\nListType (Append {a} xs ys) = List a\n\ndata MessagePID : (iface : reqType -> Type) -> Type where\n MkMessage : PID -> MessagePID iface\n\nNoRecv : Void -> Type\nNoRecv = const Void\n\ndata ProcState = Ready | Sent | Looping\n\ndata Process : (iface : reqType -> Type) ->\n Type -> ProcState -> ProcState -> Type where\n Request : MessagePID service_iface ->\n (msg : service_reqType) ->\n Process iface (service_iface msg) st st\n Respond : ((msg : reqType) -> Process iface (iface msg) Ready Ready) ->\n Process iface (Maybe reqType) st Sent\n Spawn : Process service_iface () Ready Looping ->\n Process iface (Maybe (MessagePID service_iface)) st st\n\n Loop : Inf (Process iface a Ready Looping) ->\n Process iface a Sent Looping\n Action : IO a -> Process iface a st st\n Pure : a -> Process iface a st st\n (>>=) : Process iface a st1 st2 -> (a -> Process iface b st2 st3) ->\n Process iface b st1 st3\n\npublic export\ndata Fuel = Dry | More (Lazy Fuel)\n\nexport partial\nforever : Fuel\nforever = More forever\n\ntotal\nrun : Fuel -> Process iface t in_state out_state -> IO (Maybe t)\nrun fuel (Request {service_iface} (MkMessage process) msg)\n = do Just chan <- connect process\n | _ => pure Nothing\n ok <- unsafeSend chan msg\n if ok then do Just x <- unsafeRecv (service_iface msg) chan\n | Nothing => pure Nothing\n pure (Just x)\n else pure Nothing\nrun fuel (Respond {reqType} calc)\n = do Just sender <- listen 1\n | Nothing => pure (Just Nothing)\n Just msg <- unsafeRecv reqType sender\n | Nothing => pure (Just Nothing)\n Just res <- run fuel (calc msg)\n | Nothing => pure Nothing\n unsafeSend sender res\n pure (Just (Just msg))\nrun (More fuel) (Loop proc) = run fuel proc\nrun fuel (Spawn proc) = do Just pid <- spawn (do run fuel proc\n pure ())\n | Nothing => pure (Just Nothing)\n pure (Just (Just (MkMessage pid)))\nrun fuel (Action act) = do res <- act\n pure (Just res)\nrun fuel (Pure val) = pure (Just val)\nrun fuel (act >>= next) = do Just x <- run fuel act\n | Nothing => pure Nothing\n run fuel (next x)\nrun Dry _ = pure Nothing\n\nService : (iface : reqType -> Type) -> Type -> Type\nService iface a = Process iface a Ready Looping\n\nClient : Type -> Type\nClient a = Process NoRecv a Ready Ready\n\n{-\nprocAdderBad1 : Process () Ready Looping\nprocAdderBad1 = do Action (putStrLn \"I'm out of the office today\")\n Loop procAdder_bad1\n\nprocAdderBad2 : Process () Ready Looping\nprocAdderBad2 = Loop procAdder_bad2\n -}\n\nprocAdder : Service AdderType ()\nprocAdder = do Respond (\\msg => case msg of\n Add x y => Pure (x + y))\n Loop procAdder\n\nprocMain : Client ()\nprocMain = do Just adder_id <- Spawn procAdder\n | Nothing => Action (putStrLn \"Spawn failed\")\n answer <- Request adder_id (Add 2 3)\n Action (printLn answer)\n\npartial\nrunProc : Process iface () in_state out_state -> IO ()\nrunProc proc = do run forever proc\n pure ()\n\nmain : IO ()\nmain = runProc procMain\n" }, { "path": "Chapter15/ProcessLib.idr", "content": "module ProcessLib\n\nimport System.Concurrency.Channels\n\n%default total\n\nexport\ndata MessagePID : (iface : reqType -> Type) -> Type where\n MkMessage : PID -> MessagePID iface\n\npublic export\nNoRecv : Void -> Type\nNoRecv = const Void\n\npublic export\ndata ProcState = Ready | Sent | Looping\n\npublic export\ndata Process : (iface : reqType -> Type) ->\n Type -> ProcState -> ProcState -> Type where\n Request : MessagePID service_iface ->\n (msg : service_reqType) ->\n Process iface (service_iface msg) st st\n Respond : ((msg : reqType) -> Process iface (iface msg) Ready Ready) ->\n Process iface (Maybe reqType) st Sent\n Spawn : Process service_iface () Ready Looping ->\n Process iface (Maybe (MessagePID service_iface)) st st\n\n Loop : Inf (Process iface a Ready Looping) ->\n Process iface a Sent Looping\n Action : IO a -> Process iface a st st\n Pure : a -> Process iface a st st\n (>>=) : Process iface a st1 st2 -> (a -> Process iface b st2 st3) ->\n Process iface b st1 st3\n\npublic export\ndata Fuel = Dry | More (Lazy Fuel)\n\nexport partial\nforever : Fuel\nforever = More forever\n\nexport total\nrun : Fuel -> Process iface t in_state out_state -> IO (Maybe t)\nrun fuel (Request {service_iface} (MkMessage process) msg)\n = do Just chan <- connect process\n | _ => pure Nothing\n ok <- unsafeSend chan msg\n if ok then do Just x <- unsafeRecv (service_iface msg) chan\n | Nothing => pure Nothing\n pure (Just x)\n else pure Nothing\nrun fuel (Respond {reqType} calc)\n = do Just sender <- listen 1\n | Nothing => pure (Just Nothing)\n Just msg <- unsafeRecv reqType sender\n | Nothing => pure (Just Nothing)\n Just res <- run fuel (calc msg)\n | Nothing => pure Nothing\n unsafeSend sender res\n pure (Just (Just msg))\nrun (More fuel) (Loop proc) = run fuel proc\nrun fuel (Spawn proc) = do Just pid <- spawn (do run fuel proc\n pure ())\n | Nothing => pure (Just Nothing)\n pure (Just (Just (MkMessage pid)))\nrun fuel (Action act) = do res <- act\n pure (Just res)\nrun fuel (Pure val) = pure (Just val)\nrun fuel (act >>= next) = do Just x <- run fuel act\n | Nothing => pure Nothing\n run fuel (next x)\nrun Dry _ = pure Nothing\n\npublic export\nService : (iface : reqType -> Type) -> Type -> Type\nService iface a = Process iface a Ready Looping\n\npublic export\nClient : Type -> Type\nClient a = Process NoRecv a Ready Ready\n\npartial export\nrunProc : Process iface () in_state out_state -> IO ()\nrunProc proc = do run forever proc\n pure ()\n" }, { "path": "Chapter15/ProcessLoop.idr", "content": "import System.Concurrency.Channels\n\ndata Message = Add Nat Nat\n\ndata MessagePID = MkMessage PID\n\ndata Process : Type -> Type where\n Request : MessagePID -> Message -> Process (Maybe Nat)\n Respond : ((msg : Message) -> Process Nat) -> Process (Maybe Message)\n Spawn : Process () -> Process (Maybe MessagePID)\n\n Loop : Inf (Process a) -> Process a\n Action : IO a -> Process a\n Pure : a -> Process a\n (>>=) : Process a -> (a -> Process b) -> Process b\n\npublic export\ndata Fuel = Dry | More (Lazy Fuel)\n\nexport partial\nforever : Fuel\nforever = More forever\n\ntotal\nrun : Fuel -> Process t -> IO (Maybe t)\nrun fuel (Request (MkMessage process) msg)\n = do Just chan <- connect process\n | _ => pure (Just Nothing)\n ok <- unsafeSend chan msg\n if ok then do Just x <- unsafeRecv Nat chan\n | Nothing => pure (Just Nothing)\n pure (Just (Just x))\n else pure (Just Nothing)\nrun fuel (Respond f)\n = do Just sender <- listen 1\n | Nothing => pure (Just Nothing)\n Just msg <- unsafeRecv Message sender\n | Nothing => pure (Just Nothing)\n Just res <- run fuel (f msg)\n | Nothing => pure Nothing\n unsafeSend sender res\n pure (Just (Just msg))\nrun (More fuel) (Loop proc) = run fuel proc\nrun fuel (Spawn proc) = do Just pid <- spawn (do run fuel proc\n pure ())\n | Nothing => pure Nothing\n pure (Just (Just (MkMessage pid)))\nrun fuel (Action act) = do res <- act\n pure (Just res)\nrun fuel (Pure val) = pure (Just val)\nrun fuel (act >>= next) = do Just x <- run fuel act\n | Nothing => pure Nothing\n run fuel (next x)\nrun Dry _ = pure Nothing\n\nprocAdder : Process ()\nprocAdder = do Respond (\\msg => case msg of\n Add x y => Pure (x + y))\n Loop procAdder\n\nprocMain : Process ()\nprocMain = do Just adder_id <- Spawn procAdder\n | Nothing => Action (putStrLn \"Spawn failed\")\n Just answer <- Request adder_id (Add 2 3)\n | Nothing => Action (putStrLn \"Request failed\")\n Action (printLn answer)\n\npartial\nrunProc : Process () -> IO ()\nrunProc proc = do run forever proc\n pure ()\n\nmain : IO ()\nmain = runProc procMain\n" }, { "path": "Chapter15/ProcessState.idr", "content": "import System.Concurrency.Channels\n\ndata Message = Add Nat Nat\n\ndata MessagePID = MkMessage PID\n\ndata ProcState = Ready | Sent | Looping\n\ndata Process : Type -> ProcState -> ProcState -> Type where\n Request : MessagePID -> Message -> Process Nat st st\n Respond : ((msg : Message) -> Process Nat Ready Ready) ->\n Process (Maybe Message) st Sent\n Spawn : Process () Ready Looping ->\n Process (Maybe MessagePID) st st\n\n Loop : Inf (Process a Ready Looping) ->\n Process a Sent Looping\n Action : IO a -> Process a st st\n Pure : a -> Process a st st\n (>>=) : Process a st1 st2 -> (a -> Process b st2 st3) ->\n Process b st1 st3\n\npublic export\ndata Fuel = Dry | More (Lazy Fuel)\n\nexport partial\nforever : Fuel\nforever = More forever\n\ntotal\nrun : Fuel -> Process t in_state out_state -> IO (Maybe t)\nrun fuel (Request (MkMessage process) msg)\n = do Just chan <- connect process\n | _ => pure Nothing\n ok <- unsafeSend chan msg\n if ok then do Just x <- unsafeRecv Nat chan\n | Nothing => pure Nothing\n pure (Just x)\n else pure Nothing\nrun fuel (Respond f)\n = do Just sender <- listen 1\n | Nothing => pure (Just Nothing)\n Just msg <- unsafeRecv Message sender\n | Nothing => pure (Just Nothing)\n Just res <- run fuel (f msg)\n | Nothing => pure Nothing\n unsafeSend sender res\n pure (Just (Just msg))\nrun (More fuel) (Loop proc) = run fuel proc\nrun fuel (Spawn proc) = do Just pid <- spawn (do run fuel proc\n pure ())\n | Nothing => pure (Just Nothing)\n pure (Just (Just (MkMessage pid)))\nrun fuel (Action act) = do res <- act\n pure (Just res)\nrun fuel (Pure val) = pure (Just val)\nrun fuel (act >>= next) = do Just x <- run fuel act\n | Nothing => pure Nothing\n run fuel (next x)\nrun Dry _ = pure Nothing\n\nService : Type -> Type\nService a = Process a Ready Looping\n\nClient : Type -> Type\nClient a = Process a Ready Ready\n\n{-\nprocAdder_bad1 : Process () Ready Looping\nprocAdder_bad1 = do Action (putStrLn \"I'm out of the office today\")\n Loop procAdder_bad1\n\nprocAdder_bad2 : Process () Ready Looping\nprocAdder_bad2 = Loop procAdder_bad2\n -}\n\nprocAdder : Service ()\nprocAdder = do Respond (\\msg => case msg of\n Add x y => Pure (x + y))\n Loop procAdder\n\nprocMain : Client ()\nprocMain = do Just adder_id <- Spawn procAdder\n | Nothing => Action (putStrLn \"Spawn failed\")\n answer <- Request adder_id (Add 2 3)\n Action (printLn answer)\n\npartial\nrunProc : Process () in_state out_state -> IO ()\nrunProc proc = do run forever proc\n pure ()\n\nmain : IO ()\nmain = runProc procMain\n" }, { "path": "Chapter15/WordCount.idr", "content": "import ProcessLib\n\nrecord WCData where\n constructor MkWCData\n wordCount : Nat\n lineCount : Nat\n\ndoCount : (content : String) -> WCData\ndoCount content = let lcount = length (lines content)\n wcount = length (words content) in\n MkWCData lcount wcount\n\ndata WC = CountFile String\n | GetData String\n\nWCType : WC -> Type\nWCType (CountFile x) = ()\nWCType (GetData x) = Maybe WCData\n\n\ncountFile : List (String, WCData) -> String ->\n Process WCType (List (String, WCData)) Sent Sent\ncountFile files fname =\n do Right content <- Action (readFile fname)\n | Left err => Pure files\n let count = doCount content\n Action (putStrLn (\"Counting complete for \" ++ fname))\n Pure ((fname, doCount content) :: files)\n\ntotal\nwcService : (loaded : List (String, WCData)) -> Service WCType ()\nwcService loaded\n = do msg <- Respond (\\msg => case msg of\n CountFile fname => Pure ()\n GetData fname =>\n Pure (lookup fname loaded))\n newLoaded <- case msg of\n Just (CountFile fname) =>\n countFile loaded fname\n _ => Pure loaded\n Loop (wcService newLoaded)\n\nprocMain : Client ()\nprocMain = do Just wc <- Spawn (wcService [])\n | Nothing => Action (putStrLn \"Spawn failed\")\n Action (putStrLn \"Counting test.txt\")\n Request wc (CountFile \"test.txt\")\n Action (putStrLn \"Processing\")\n Just wcdata <- Request wc (GetData \"test.txt\")\n | Nothing => Action (putStrLn \"File error\")\n Action (putStrLn (\"Words: \" ++ show (wordCount wcdata)))\n Action (putStrLn (\"Lines: \" ++ show (lineCount wcdata)))\n\npartial\nmain : IO ()\nmain = runProc procMain\n" }, { "path": "Chapter15/test.txt", "content": "test test\ntest\ntest test test\ntest\n" }, { "path": "Chapter2/AveMain.idr", "content": "module Main\n\nimport Average\n\nshowAverage : String -> String\nshowAverage str = \"The average word length is: \" ++\n show (average str) ++ \"\\n\"\n\nmain : IO ()\nmain = repl \"Enter a string: \" showAverage\n" }, { "path": "Chapter2/Average.idr", "content": "module Average\n\n||| Calculate the average length of words in a string.\n||| @str a string containing words separated by whitespace.\nexport\naverage : (str : String) -> Double\naverage str = let numWords = wordCount str\n totalLength = sum (allLengths (words str)) in\n cast totalLength / cast numWords\n where\n wordCount : String -> Nat\n wordCount str = length (words str)\n\n allLengths : List String -> List Nat\n allLengths strs = map length strs\n" }, { "path": "Chapter2/Double.idr", "content": "double : Int -> Int\ndouble x = x + x\n" }, { "path": "Chapter2/Exercises/ex_2.idr", "content": "{-\n\n1. (String, String, String)\n List String\n ((Char, String), Char)\n\n-}\n\n{- 2 -}\n\npalindrome : String -> Bool\npalindrome str = str == reverse str\n\n{- 3 -}\n\npalindrome_q3 : String -> Bool\npalindrome_q3 str = let strL = toLower str in\n strL == reverse strL\n\n{- 4 -}\n\npalindrome_q4 : String -> Bool\npalindrome_q4 str = if length str > 10\n then palindrome_q3 str\n else False\n\n{- 5 -}\n\npalindrome_q5 : Nat -> String -> Bool\npalindrome_q5 min str = if length str > min\n then palindrome_q3 str\n else False\n\n{- 6 -}\n\ncounts : String -> (Nat, Nat)\ncounts str = (length (words str), length str)\n\n{- 7 -}\n\ntop_ten : Ord a => List a -> List a\ntop_ten xs = take 10 (reverse (sort xs))\n\n{- 8 -}\n\nover_length : Nat -> List String -> Nat\nover_length num xs = let lengths = map length xs in\n length (filter (> num) lengths)\n" }, { "path": "Chapter2/Exercises/ex_2_counts.idr", "content": "module Main\n\ncounts : String -> (Nat, Nat)\ncounts str = (length (words str), length str)\n\nmain : IO ()\nmain = repl \"Enter a string: \" show_counts\n where\n show_counts : String -> String\n show_counts x = show (counts x) ++ \"\\n\"\n" }, { "path": "Chapter2/Exercises/ex_2_palindrome.idr", "content": "module Main\n\npalindrome : String -> Bool\npalindrome str = let strL = toLower str in\n strL == reverse strL\n\nmain : IO ()\nmain = repl \"Enter a string: \" show_palindrome\n where\n show_palindrome : String -> String\n show_palindrome x = show (palindrome x) ++ \"\\n\"\n \n" }, { "path": "Chapter2/Generic.idr", "content": "identityInt : Int -> Int\nidentityInt x = x\n\nidentityString : String -> String\nidentityString x = x\n\nidentityBool : Bool -> Bool\nidentityBool x = x\n\nidentity : ty -> ty\nidentity x = x\n\ndoubleNat : Nat -> Nat\ndoubleNat x = x * x\n\ndoubleInteger : Integer -> Integer\ndoubleInteger x = x * x\n\ndouble : Num ty => ty -> ty\ndouble x = x * x\n" }, { "path": "Chapter2/HOF.idr", "content": "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 -> Shape\n\nquadruple : Num a => a -> a\nquadruple = twice double\n\nturn_around : Shape -> Shape\nturn_around = twice rotate\n" }, { "path": "Chapter2/Let_Where.idr", "content": "longer : String -> String -> Nat\nlonger word1 word2\n = let len1 = length word1\n len2 = length word2 in\n if len1 > len2 then len1 else len2\n\npythagoras : Double -> Double -> Double\npythagoras x y = sqrt (square x + square y)\n where\n square : Double -> Double\n square x = x * x\n" }, { "path": "Chapter2/Partial.idr", "content": "add : Int -> Int -> Int\nadd x y = x + y\n" }, { "path": "Chapter2/Reverse.idr", "content": "module Main\n\nmain : IO ()\nmain = repl \"> \" reverse\n" }, { "path": "Chapter3/Exercises/ex_3_2.idr", "content": "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\nmy_reverse : List a -> List a\nmy_reverse [] = []\nmy_reverse (x :: xs) = my_reverse xs ++ [x]\n\n{- 3 -}\n\nmy_map : (a -> b) -> List a -> List b\nmy_map f [] = []\nmy_map f (x :: xs) = f x :: my_map f xs\n\n{- 4 -}\n\nmy_vect_map : (a -> b) -> Vect n a -> Vect n b\nmy_vect_map f [] = []\nmy_vect_map f (x :: xs) = f x :: my_vect_map f xs\n" }, { "path": "Chapter3/Exercises/ex_3_3.idr", "content": "import Data.Vect\n\n{- 1 -}\n\ncreate_empties : Vect n (Vect 0 elem)\ncreate_empties = replicate _ []\n\ntranspose_mat : Vect m (Vect n elem) -> Vect n (Vect m elem)\ntranspose_mat [] = create_empties\ntranspose_mat (x :: xs) = let xs_trans = transpose_mat xs in\n zipWith (::) x xs_trans\n\n{- 2 -}\n\naddMatrix : Num a => Vect n (Vect m a) -> Vect n (Vect m a) -> Vect n (Vect m a)\naddMatrix [] [] = []\naddMatrix (x :: xs) (y :: ys) = zipWith (+) x y :: addMatrix xs ys\n\n{- 3 -}\n\nmultVecs : Num a => (xs : Vect n a) -> (ys : Vect n a) -> a\nmultVecs xs ys = sum (zipWith (*) xs ys)\n\nmkRow : Num a => (x : Vect n a) -> (ys_trans : Vect p (Vect n a)) -> Vect p a\nmkRow x [] = []\nmkRow x (y :: xs) = multVecs x y :: mkRow x xs\n\nmultMatrix_helper : Num a => (xs : Vect m (Vect n a)) -> (ys_trans : Vect p (Vect n a)) -> Vect m (Vect p a)\nmultMatrix_helper [] ys_trans = []\nmultMatrix_helper (x :: xs) ys_trans \n = mkRow x ys_trans :: multMatrix_helper xs ys_trans\n\nmultMatrix : Num a => Vect m (Vect n a) -> Vect n (Vect p a) -> Vect m (Vect p a)\nmultMatrix xs ys = let ys_trans = transpose_mat ys in\n multMatrix_helper xs ys_trans\n" }, { "path": "Chapter3/IsEven.idr", "content": "isEven' : Nat -> Bool\nisEven' Z = True\nisEven' (S k) = not (isEven' k)\n\nmutual\n isEven : Nat -> Bool\n isEven Z = True\n isEven (S k) = isOdd k\n\n isOdd : Nat -> Bool\n isOdd Z = False\n isOdd (S k) = isEven k\n" }, { "path": "Chapter3/Matrix.idr", "content": "import Data.Vect\n\ncreateEmpties : Vect n (Vect 0 elem)\ncreateEmpties {n = Z} = []\ncreateEmpties {n = (S k)} = [] :: createEmpties\n\ntransposeHelper : (x : Vect n elem) -> (xs_trans : Vect n (Vect k elem)) -> Vect n (Vect (S k) elem)\ntransposeHelper [] [] = []\ntransposeHelper (x :: xs) (y :: ys) = (x :: y) :: transposeHelper xs ys\n\ntransposeMat : Vect m (Vect n elem) -> Vect n (Vect m elem)\ntransposeMat [] = createEmpties\ntransposeMat (x :: xs) = let xsTrans = transposeMat xs in\n transposeHelper x xsTrans\n" }, { "path": "Chapter3/VecSort.idr", "content": "import Data.Vect\n\ninsert : Ord elem => (x : elem) -> (xsSorted : Vect k elem) -> Vect (S k) elem\ninsert x [] = [x]\ninsert x (y :: xs) = case x < y of\n False => y :: insert x xs\n True => x :: y :: xs\n\ninsSort : Ord elem => Vect n elem -> Vect n elem\ninsSort [] = []\ninsSort (x :: xs) = let xsSorted = insSort xs in\n insert x xsSorted\n" }, { "path": "Chapter3/Vectors.idr", "content": "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\ntenInts : Vect 10 Int\ntenInts = fourInts ++ sixInts\n" }, { "path": "Chapter3/WordLength.idr", "content": "allLengths : List String -> List Nat\nallLengths [] = []\nallLengths (word :: words) = length word :: allLengths words\n" }, { "path": "Chapter3/WordLength_vec.idr", "content": "import Data.Vect\n\ntotal\nallLengths : Vect len String -> Vect len Nat\nallLengths [] = []\nallLengths (word :: words) = length word :: allLengths words\n" }, { "path": "Chapter3/XOR.idr", "content": "xor : Bool -> Bool -> Bool\nxor False y = y\nxor True y = not y\n" }, { "path": "Chapter4/BSTree.idr", "content": "data BSTree : Type -> Type where\n Empty : Ord elem => BSTree elem\n Node : Ord elem => (left : BSTree elem) -> (val : elem) ->\n (right : BSTree elem) -> BSTree elem\n \ninsert : elem -> BSTree elem -> BSTree elem\ninsert x Empty = Node Empty x Empty\ninsert x orig@(Node left val right)\n = case compare x val of\n LT => Node (insert x left) val right\n EQ => orig\n GT => Node left val (insert x right)\n" }, { "path": "Chapter4/DataStore.idr", "content": "module Main\n\nimport Data.Vect\n\ndata DataStore : Type where\n MkData : (size : Nat) -> (items : Vect size String) -> DataStore\n\nsize : DataStore -> Nat\nsize (MkData size' items') = size'\n\nitems : (store : DataStore) -> Vect (size store) String\nitems (MkData size' items') = items'\n\naddToStore : DataStore -> String -> DataStore\naddToStore (MkData size store) newitem = MkData _ (addToData store)\n where\n addToData : Vect oldsize String -> Vect (S oldsize) String\n addToData [] = [newitem]\n addToData (x :: xs) = x :: addToData xs\n\ndata Command = Add String\n | Get Integer\n | Quit\n\nparseCommand : String -> String -> Maybe Command\nparseCommand \"add\" str = Just (Add str)\nparseCommand \"get\" val = case all isDigit (unpack val) of\n False => Nothing\n True => Just (Get (cast val))\nparseCommand \"quit\" \"\" = Just Quit\nparseCommand _ _ = Nothing\n\nparse : (input : String) -> Maybe Command\nparse input = case span (/= ' ') input of\n (cmd, args) => parseCommand cmd (ltrim args)\n\ngetEntry : (pos : Integer) -> (store : DataStore) ->\n Maybe (String, DataStore)\ngetEntry pos store\n = let store_items = items store in\n case integerToFin pos (size store) of\n Nothing => Just (\"Out of range\\n\", store)\n Just id => Just (index id store_items ++ \"\\n\", store)\n\nprocessInput : DataStore -> String -> Maybe (String, DataStore)\nprocessInput store input\n = case parse input of\n Nothing => Just (\"Invalid command\\n\", store)\n Just (Add item) =>\n Just (\"ID \" ++ show (size store) ++ \"\\n\", addToStore store item)\n Just (Get pos) => getEntry pos store\n Just Quit => Nothing\n\nmain : IO ()\nmain = replWith (MkData _ []) \"Command: \" processInput\n" }, { "path": "Chapter4/Direction.idr", "content": "data Direction = North | East | South | West\n\nturnClockwise : Direction -> Direction\nturnClockwise North = East\nturnClockwise East = South\nturnClockwise South = West\nturnClockwise West = North\n" }, { "path": "Chapter4/Exercises/ex_4_1.idr", "content": "{- Support code -}\n\ndata Shape = ||| A triangle, with its base length and height\n Triangle Double Double\n | ||| A rectangle, with its length and height\n Rectangle Double Double\n | ||| A circle, with its radius\n Circle Double\n\narea : Shape -> Double\narea (Triangle base height) = 0.5 * base * height\narea (Rectangle length height) = length * height\narea (Circle radius) = pi * radius * radius\n\ndata Picture = Primitive Shape\n | Combine Picture Picture\n | Rotate Double Picture\n | Translate Double Double Picture\n\ntestPic1 : Picture\ntestPic1 = Combine (Primitive (Triangle 2 3)) \n (Primitive (Triangle 2 4))\n\ntestPic2 : Picture\ntestPic2 = Combine (Primitive (Rectangle 1 3)) \n (Primitive (Circle 4))\n\ndata Tree elem = Empty\n | Node (Tree elem) elem (Tree elem)\n\n%name Tree tree, tree1\n\ninsert : Ord elem => elem -> Tree elem -> Tree elem\ninsert x Empty = Node Empty x Empty\ninsert x orig@(Node left val right)\n = case compare x val of\n LT => Node (insert x left) val right\n EQ => orig\n GT => Node left val (insert x right)\n\n{- Answers -}\n\n{- 1 -}\n\nlistToTree : Ord a => List a -> Tree a\nlistToTree [] = Empty\nlistToTree (x :: xs) = insert x (listToTree xs)\n\n{- 2 -}\n\ntreeToList : Tree a -> List a\ntreeToList Empty = []\ntreeToList (Node left val right) = treeToList left ++ val :: treeToList right\n\n{- 3 -}\n\ndata Expr = Val Int\n | Add Expr Expr\n | Sub Expr Expr\n | Mult Expr Expr\n\n{- 4 -}\n\nevaluate : Expr -> Int\nevaluate (Val x) = x\nevaluate (Add x y) = evaluate x + evaluate y\nevaluate (Sub x y) = evaluate x - evaluate y\nevaluate (Mult x y) = evaluate x * evaluate y\n\n{- 5 -}\n\nmaxMaybe : Ord a => Maybe a -> Maybe a -> Maybe a\nmaxMaybe Nothing Nothing = Nothing\nmaxMaybe Nothing (Just x) = Just x\nmaxMaybe (Just x) Nothing = Just x\nmaxMaybe (Just x) (Just y) = Just (max x y)\n\n{- 6 -}\n\nbiggestTriangle : Picture -> Maybe Double\nbiggestTriangle (Primitive tri@(Triangle x y)) = Just (area tri)\nbiggestTriangle (Primitive _) = Nothing\nbiggestTriangle (Combine x y) = maxMaybe (biggestTriangle x) (biggestTriangle y)\nbiggestTriangle (Rotate x pic) = biggestTriangle pic\nbiggestTriangle (Translate x y pic) = biggestTriangle pic\n" }, { "path": "Chapter4/Exercises/ex_4_2.idr", "content": "{- 1 -}\n\ndata PowerSource = Petrol | Pedal\n\ndata Vehicle : PowerSource -> Type where\n Bicycle : Vehicle Pedal\n Unicycle : Vehicle Pedal\n Motorcycle : (fuel : Nat) -> Vehicle Petrol\n Car : (fuel : Nat) -> Vehicle Petrol\n Bus : (fuel : Nat) -> Vehicle Petrol\n\nwheels : Vehicle power -> Nat\nwheels Bicycle = 2\nwheels Unicycle = 1\nwheels (Motorcycle fuel) = 2\nwheels (Car fuel) = 4\nwheels (Bus fuel) = 4\n\nrefuel : Vehicle Petrol -> Vehicle Petrol\nrefuel (Car fuel) = Car 100\nrefuel (Bus fuel) = Bus 200\nrefuel (Motorcycle fuel) = Motorcycle 50\n" }, { "path": "Chapter4/Exercises/ex_4_2_1.idr", "content": "{- 1 -}\n\ndata PowerSource = Petrol | Pedal\n\ndata Vehicle : PowerSource -> Type where\n Bicycle : Vehicle Pedal\n Unicycle : Vehicle Pedal\n Motorcycle : (fuel : Nat) -> Vehicle Petrol\n Car : (fuel : Nat) -> Vehicle Petrol\n Bus : (fuel : Nat) -> Vehicle Petrol\n\nwheels : Vehicle power -> Nat\nwheels Bicycle = 2\nwheels Unicycle = 1\nwheels (Motorcycle fuel) = 2\nwheels (Car fuel) = 4\nwheels (Bus fuel) = 4\n\nrefuel : Vehicle Petrol -> Vehicle Petrol\nrefuel (Car fuel) = Car 100\nrefuel (Bus fuel) = Bus 200\nrefuel (Motorcycle fuel) = Motorcycle 50\n" }, { "path": "Chapter4/Exercises/ex_4_2_2.idr", "content": "{- 2 -}\n\ndata PowerSource = Petrol | Pedal | Electric\n\ndata Vehicle : PowerSource -> Type where\n Bicycle : Vehicle Pedal\n Unicycle : Vehicle Pedal\n Motorcycle : (fuel : Nat) -> Vehicle Petrol\n Car : (fuel : Nat) -> Vehicle Petrol\n Bus : (fuel : Nat) -> Vehicle Petrol\n Tram : Vehicle Electric\n\nwheels : Vehicle power -> Nat\nwheels Bicycle = 2\nwheels Unicycle = 1\nwheels (Motorcycle fuel) = 2\nwheels (Car fuel) = 4\nwheels (Bus fuel) = 4\nwheels Tram = 8\n\nrefuel : Vehicle Petrol -> Vehicle Petrol\nrefuel (Car fuel) = Car 100\nrefuel (Bus fuel) = Bus 200\nrefuel (Motorcycle fuel) = Motorcycle 50\n" }, { "path": "Chapter4/Exercises/ex_4_2_3.idr", "content": "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 Vect xs, ys, zs\n\n{- 3 and 4-}\n\nvectTake : (n : Nat) -> Vect (n + m) a -> Vect n a\nvectTake Z xs = []\nvectTake (S k) (x :: xs) = x :: vectTake k xs\n" }, { "path": "Chapter4/Exercises/ex_4_2_5.idr", "content": "import Data.Vect\n\n{- 5 -}\n\nsumEntries : Num a => (pos : Integer) -> Vect n a -> Vect n a -> Maybe a\nsumEntries {n} pos xs ys = case integerToFin pos n of\n Nothing => Nothing\n Just idx => Just (index idx xs + index idx ys)\n" }, { "path": "Chapter4/Exercises/ex_4_3.idr", "content": "module Main\nimport Data.Vect\n\ndata DataStore : Type where\n MkData : (size : Nat) -> (items : Vect size String) -> DataStore\n\nsize : DataStore -> Nat\nsize (MkData size' items') = size'\n\nitems : (store : DataStore) -> Vect (size store) String\nitems (MkData size' items') = items'\n\naddToStore : DataStore -> String -> DataStore\naddToStore (MkData size store) newitem = MkData _ (addToData store)\n where\n addToData : Vect oldsize String -> Vect (S oldsize) String\n addToData [] = [newitem]\n addToData (x :: xs) = x :: addToData xs\n\ndata Command = Add String\n | Get Integer\n | Size {- question 1 -}\n | Search String {- question 2 -}\n | Quit\n\nparseCommand : List String -> Maybe Command\nparseCommand (\"add\" :: rest) = Just (Add (unwords rest))\nparseCommand [\"get\", val] = case all isDigit (unpack val) of\n False => Nothing\n True => Just (Get (cast val))\nparseCommand [\"quit\"] = Just Quit\nparseCommand [\"size\"] = Just Size {- question 1 -}\nparseCommand (\"search\" :: rest) = Just (Search (unwords rest)) {- question 2 -}\nparseCommand _ = Nothing\n\nparse : (input : String) -> Maybe Command\nparse input = parseCommand (words input)\n\ngetEntry : (pos : Integer) -> (store : DataStore) ->\n Maybe (String, DataStore)\ngetEntry pos store\n = let store_items = items store in\n case integerToFin pos (size store) of\n Nothing => Just (\"Out of range\\n\", store)\n Just id => Just (index id (items store) ++ \"\\n\", store)\n\n{- question 2/3 -}\nsearchString : Nat -> (items : Vect n String) -> (str : String) -> String\nsearchString idx [] str = \"\"\nsearchString idx (x :: xs) str\n = let rest = searchString (idx + 1) xs str in\n if isInfixOf str x\n then show idx ++ \": \" ++ x ++ \"\\n\" ++ rest\n else rest\n\nprocessInput : DataStore -> String -> Maybe (String, DataStore)\nprocessInput store input\n = case parse input of\n Nothing => Just (\"Invalid command\\n\", store)\n Just (Add item) =>\n Just (\"ID \" ++ show (size store) ++ \"\\n\", addToStore store item)\n Just (Get pos) => getEntry pos store\n Just Size => Just (show (size store) ++ \"\\n\", store) {- question 1 -}\n Just (Search str) => Just (searchString 0 (items store) str, store) {- question 2 -}\n Just Quit => Nothing\n\n\nmain : IO ()\nmain = replWith (MkData _ []) \"Command: \" processInput\n" }, { "path": "Chapter4/Generic.idr", "content": "safeDivide : Double -> Double -> Maybe Double\nsafeDivide x y = if y == 0 then Nothing\n else Just (x / y)\n" }, { "path": "Chapter4/Picture.idr", "content": "data Shape = ||| A triangle, with its base length and height\n Triangle Double Double\n | ||| A rectangle, with its length and height\n Rectangle Double Double\n | ||| A circle, with its radius\n Circle Double\n\narea : Shape -> Double\narea (Triangle base height) = 0.5 * base * height\narea (Rectangle length height) = length * height\narea (Circle radius) = pi * radius * radius\n\ndata Picture = Primitive Shape\n | Combine Picture Picture\n | Rotate Double Picture\n | Translate Double Double Picture\n\nrectangle : Picture\nrectangle = Primitive (Rectangle 20 10)\n\ncircle : Picture\ncircle = Primitive (Circle 5)\n\ntriangle : Picture\ntriangle = Primitive (Triangle 10 10)\n\ntestPicture : Picture\ntestPicture = Combine (Translate 5 5 rectangle)\n (Combine (Translate 35 5 circle)\n (Translate 15 25 triangle))\n\npictureArea : Picture -> Double\npictureArea (Primitive shape) = area shape\npictureArea (Combine pic pic1) = pictureArea pic + pictureArea pic1\npictureArea (Rotate x pic) = pictureArea pic\npictureArea (Translate x y pic) = pictureArea pic\n" }, { "path": "Chapter4/Shape.idr", "content": "data Shape = ||| A triangle, with its base length and height\n Triangle Double Double\n | ||| A rectangle, with its length and height\n Rectangle Double Double\n | ||| A circle, with its radius\n Circle Double\n \narea : Shape -> Double\narea (Triangle base height) = 0.5 * base * height\narea (Rectangle length height) = length * height\narea (Circle radius) = pi * radius * radius\n" }, { "path": "Chapter4/SumInputs.idr", "content": "sumInputs : Integer -> String -> Maybe (String, Integer)\nsumInputs tot inp\n = let val = cast inp in\n if val < 0 \n then Nothing\n else let newVal = tot + val in\n Just (\"Subtotal: \" ++ show newVal ++ \"\\n\", newVal)\n \nmain : IO ()\nmain = replWith 0 \"Value: \" sumInputs\n" }, { "path": "Chapter4/Tree.idr", "content": "data Tree elem = Empty\n | Node (Tree elem) elem (Tree elem)\n\n%name Tree tree, tree1\n\ninsert : Ord elem => elem -> Tree elem -> Tree elem\ninsert x Empty = Node Empty x Empty\ninsert x orig@(Node left val right)\n = case compare x val of\n LT => Node (insert x left) val right\n EQ => orig\n GT => Node left val (insert x right)\n" }, { "path": "Chapter4/TryIndex.idr", "content": "import Data.Vect\n\ntryIndex : Integer -> Vect n a -> Maybe a\ntryIndex {n} i xs = case integerToFin i n of\n Nothing => Nothing\n Just idx => Just (index idx xs)\n" }, { "path": "Chapter4/Vect.idr", "content": "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 Vect xs, ys, zs\n\nappend : Vect n elem -> Vect m elem -> Vect (n + m) elem\nappend [] ys = ys\nappend (x :: xs) ys = x :: append xs ys\n\nzip : Vect n a -> Vect n b -> Vect n (a, b)\nzip [] [] = []\nzip (x :: xs) (y :: ys) = (x, y) :: zip xs ys\n" }, { "path": "Chapter4/Vehicle.idr", "content": "data PowerSource = Petrol | Pedal\n\ndata Vehicle : PowerSource -> Type where\n Bicycle : Vehicle Pedal\n Car : (fuel : Nat) -> Vehicle Petrol\n Bus : (fuel : Nat) -> Vehicle Petrol\n\nwheels : Vehicle power -> Nat\nwheels Bicycle = 2\nwheels (Car fuel) = 4\nwheels (Bus fuel) = 4\n\nrefuel : Vehicle Petrol -> Vehicle Petrol\nrefuel (Car fuel) = Car 100\nrefuel (Bus fuel) = Bus 200\nrefuel Bicycle impossible\n" }, { "path": "Chapter5/DepPairs.idr", "content": "import Data.Vect\n\nanyVect : (n ** Vect n String)\nanyVect = (3 ** [\"Rod\", \"Jane\", \"Freddy\"])\n\nreadVect : IO (len ** Vect len String)\nreadVect = do x <- getLine\n if (x == \"\")\n then pure (_ ** [])\n else do (_ ** xs) <- readVect\n pure (_ ** x :: xs)\n\nzipInputs : IO ()\nzipInputs = do putStrLn \"Enter first vector (blank line to end):\"\n (len1 ** vec1) <- readVect\n putStrLn \"Enter second vector (blank line to end):\"\n (len2 ** vec2) <- readVect\n case exactLength len1 vec2 of\n Nothing => putStrLn \"Vectors are different lengths\"\n Just vec2' => printLn (zip vec1 vec2')\n" }, { "path": "Chapter5/Do.idr", "content": "printTwoThings : IO ()\nprintTwoThings = do putStrLn \"Hello\"\n putStrLn \"World\"\n\nprintInput : IO ()\nprintInput = do x <- getLine\n putStrLn x\n\nprintLength : IO ()\nprintLength = do putStr \"Input string: \"\n input <- getLine\n let len = length input\n putStrLn (show len)\n" }, { "path": "Chapter5/Exercises/ex_5_1.idr", "content": "{- 1 -}\n\nprintLonger : IO ()\nprintLonger = do putStr \"First string: \"\n str1 <- getLine\n putStr \"Second string: \"\n str2 <- getLine\n if length str1 > length str2\n then putStrLn (show (length str1))\n else putStrLn (show (length str2))\n\n{- 2 -}\n\nprintLonger' : IO ()\nprintLonger' = putStr \"First string: \" >>= \\_ =>\n getLine >>= \\str1 =>\n putStr \"Second string: \" >>= \\_ =>\n getLine >>= \\str2 =>\n if length str1 > length str2\n then putStrLn (show (length str1))\n else putStrLn (show (length str2))\n" }, { "path": "Chapter5/Exercises/ex_5_2_1.idr", "content": "import System\n\n{- 1 -}\n\nreadNumber : IO (Maybe Nat)\nreadNumber = do\n input <- getLine\n if all isDigit (unpack input)\n then pure (Just (cast input))\n else pure Nothing\n\nguess : (answer : Nat) -> IO ()\nguess answer = do\n putStr (\"Guess a number between 1 and 100: \")\n isNum <- readNumber\n case isNum of\n Nothing => do putStrLn \"Invalid input\"\n guess answer\n Just userguess => if userguess < answer\n then do putStrLn \"Too low\"\n guess answer\n else if userguess > answer\n then do putStrLn \"Too high\"\n guess answer\n else putStrLn \"Well done!\"\n\n{- 2 -}\n\nmain : IO ()\nmain = do t <- time\n guess (cast (t `mod` 101))\n" }, { "path": "Chapter5/Exercises/ex_5_2_3.idr", "content": "import System\n\n{- 3 -}\n\nreadNumber : IO (Maybe Nat)\nreadNumber = do\n input <- getLine\n if all isDigit (unpack input)\n then pure (Just (cast input))\n else pure Nothing\n\nguess : (target : Nat) -> (guesses : Nat) -> IO ()\nguess target guesses = do\n putStrLn (show guesses ++ \" guesses so far\")\n putStr (\"Guess a number between 1 and 100: \")\n isNum <- readNumber\n case isNum of\n Nothing => do putStrLn \"Invalid input\"\n guess target guesses\n Just userguess => if userguess < target\n then do putStrLn \"Too low\"\n guess target (guesses + 1)\n else if userguess > target\n then do putStrLn \"Too high\"\n guess target (guesses + 1)\n else putStrLn \"Well done!\"\n\nmain : IO ()\nmain = do t <- time\n guess (cast (t `mod` 101)) 0\n" }, { "path": "Chapter5/Exercises/ex_5_2_4.idr", "content": "{- 4 -}\n\nmy_repl : (prompt : String) ->\n (fn : String -> String) -> IO ()\nmy_repl prompt fn\n = do putStr prompt\n x <- getLine\n putStr (fn x)\n my_repl prompt fn\n\nmy_replWith : (state : a) -> (prompt : String) ->\n (fn : a -> String -> Maybe (String, a)) -> IO ()\nmy_replWith acc prompt fn\n = do putStr prompt\n x <- getLine\n case fn acc x of\n Just (out, acc') => do putStr out\n my_replWith acc' prompt fn\n Nothing => pure ()\n" }, { "path": "Chapter5/Exercises/ex_5_3.idr", "content": "import Data.Vect\n\n{- 1 -}\n\nreadToBlank : IO (List String)\nreadToBlank = do x <- getLine\n case x of\n \"\" => pure []\n _ => do rest <- readToBlank\n pure (x :: rest)\n\n{- 2 -}\n\nreadAndSave : IO ()\nreadAndSave = do lines <- readToBlank\n putStr \"Filename: \"\n f <- getLine\n Right () <- writeFile f (unlines lines)\n | Left err => putStrLn (show err)\n pure ()\n\n{- 3 -}\n\nreadVectFile : (filename : String) -> IO (n ** Vect n String)\nreadVectFile filename = do Right h <- openFile filename Read\n | Left err => pure (_ ** [])\n Right contents <- readContents h\n | Left err => pure (_ ** [])\n closeFile h\n pure contents\n where readContents : File -> IO (Either FileError (n ** Vect n String))\n readContents h = do eof <- fEOF h\n if eof then pure (Right (_ ** [])) else do\n Right str <- fGetLine h\n | Left err => pure (Left err)\n Right (_ ** rest) <- readContents h\n | Left err => pure (Left err)\n pure (Right (_ ** str :: rest))\n" }, { "path": "Chapter5/Hello.idr", "content": "module Main\n\nmain : IO ()\nmain = do\n putStr \"Enter your name: \"\n x <- getLine\n putStrLn (\"Hello \" ++ x ++ \"!\")\n" }, { "path": "Chapter5/Loops.idr", "content": "module Main\n\nimport System\n\ncountdown : (secs : Nat) -> IO ()\ncountdown Z = putStrLn \"Lift off!\"\ncountdown (S secs) = do putStrLn (show (S secs))\n usleep 1000000\n countdown secs\n\nreadNumber : IO (Maybe Nat)\nreadNumber = do\n input <- getLine\n if all isDigit (unpack input)\n then pure (Just (cast input))\n else pure Nothing\n\ncountdowns : IO ()\ncountdowns = do putStr \"Enter starting number: \"\n Just startNum <- readNumber\n | Nothing => do putStrLn \"Invalid input\"\n countdowns\n countdown startNum\n putStr \"Another (y/n)? \"\n yn <- getLine\n if yn == \"y\" then countdowns\n else pure ()\n" }, { "path": "Chapter5/PrintLength.idr", "content": "printLength : IO ()\nprintLength = putStr \"Input string: \" >>= \\_ =>\n getLine >>= \\input =>\n let len = length input in\n putStrLn (show len)\n \n" }, { "path": "Chapter5/ReadNum.idr", "content": "readNumber : IO (Maybe Nat)\nreadNumber = do\n input <- getLine\n if all isDigit (unpack input)\n then pure (Just (cast input))\n else pure Nothing\n\nreadNumbers_v1 : IO (Maybe (Nat, Nat))\nreadNumbers_v1 =\n do num1 <- readNumber\n case num1 of\n Nothing => pure Nothing\n Just num1_ok =>\n do num2 <- readNumber\n case num2 of\n Nothing => pure Nothing\n Just num2_ok => pure (Just (num1_ok, num2_ok))\n\nreadPair : IO (String, String)\nreadPair = do str1 <- getLine\n str2 <- getLine\n pure (str1, str2)\n\nreadNumbers_v2 : IO (Maybe (Nat, Nat))\nreadNumbers_v2 =\n do Just num1_ok <- readNumber\n Just num2_ok <- readNumber\n pure (Just (num1_ok, num2_ok))\n\nreadNumbers : IO (Maybe (Nat, Nat))\nreadNumbers =\n do Just num1_ok <- readNumber | Nothing => pure Nothing\n Just num2_ok <- readNumber | Nothing => pure Nothing\n pure (Just (num1_ok, num2_ok))\n" }, { "path": "Chapter5/ReadVect.idr", "content": "import Data.Vect\n\nreadVectLen : (len : Nat) -> IO (Vect len String)\nreadVectLen Z = pure []\nreadVectLen (S k) = do x <- getLine\n xs <- readVectLen k\n pure (x :: xs)\n\ndata VectUnknown : Type -> Type where\n MkVect : (len : Nat) -> Vect len a -> VectUnknown a\n\nreadVect : IO (VectUnknown String)\nreadVect = do x <- getLine\n if (x == \"\")\n then pure (MkVect _ [])\n else do MkVect _ xs <- readVect\n pure (MkVect _ (x :: xs))\n\nprintVect : Show a => VectUnknown a -> IO ()\nprintVect (MkVect len xs)\n = putStrLn (show xs ++ \" (length \" ++ show len ++ \")\")\n" }, { "path": "Chapter6/Adder.idr", "content": "AdderType : (numargs : Nat) -> Type -> Type\nAdderType Z numType = numType\nAdderType (S k) numType = (next : numType) -> AdderType k numType\n\nadder : Num numType =>\n (numargs : Nat) -> numType -> AdderType numargs numType\nadder Z acc = acc\nadder (S k) acc = \\next => adder k (next + acc)\n" }, { "path": "Chapter6/DataStore.idr", "content": "module Main\n\nimport Data.Vect\n\ninfixr 5 .+.\n\ndata Schema = SString | SInt | (.+.) Schema Schema\n\nSchemaType : Schema -> Type\nSchemaType SString = String\nSchemaType SInt = Int\nSchemaType (x .+. y) = (SchemaType x, SchemaType y)\n\nrecord DataStore where\n constructor MkData\n schema : Schema\n size : Nat\n items : Vect size (SchemaType schema)\n\naddToStore : (store : DataStore) -> SchemaType (schema store) -> DataStore\naddToStore (MkData schema size store) newitem = MkData schema _ (addToData store)\n where\n addToData : Vect oldsize (SchemaType schema) -> Vect (S oldsize) (SchemaType schema)\n addToData [] = [newitem]\n addToData (x :: xs) = x :: addToData xs\n\nsetSchema : (store : DataStore) -> Schema -> Maybe DataStore\nsetSchema store schema = case size store of\n Z => Just (MkData schema _ [])\n S k => Nothing\n\ndata Command : Schema -> Type where\n SetSchema : Schema -> Command schema\n Add : SchemaType schema -> Command schema\n Get : Integer -> Command schema\n Quit : Command schema\n\n\nparsePrefix : (schema : Schema) -> String -> Maybe (SchemaType schema, String)\nparsePrefix SString input = getQuoted (unpack input)\n where\n getQuoted : List Char -> Maybe (String, String)\n getQuoted ('\"' :: xs)\n = case span (/= '\"') xs of\n (quoted, '\"' :: rest) => Just (pack quoted, ltrim (pack rest))\n _ => Nothing\n getQuoted _ = Nothing\n\nparsePrefix SInt input = case span isDigit input of\n (\"\", rest) => Nothing\n (num, rest) => Just (cast num, ltrim rest)\nparsePrefix (schemal .+. schemar) input\n = case parsePrefix schemal input of\n Nothing => Nothing\n Just (l_val, input') =>\n case parsePrefix schemar input' of\n Nothing => Nothing\n Just (r_val, input'') => Just ((l_val, r_val), input'')\n\nparseBySchema : (schema : Schema) -> String -> Maybe (SchemaType schema)\nparseBySchema schema x = case parsePrefix schema x of\n Nothing => Nothing\n Just (res, \"\") => Just res\n Just _ => Nothing\n\nparseSchema : List String -> Maybe Schema\nparseSchema (\"String\" :: xs)\n = case xs of\n [] => Just SString\n _ => case parseSchema xs of\n Nothing => Nothing\n Just xs_sch => Just (SString .+. xs_sch)\nparseSchema (\"Int\" :: xs)\n = case xs of\n [] => Just SInt\n _ => case parseSchema xs of\n Nothing => Nothing\n Just xs_sch => Just (SInt .+. xs_sch)\nparseSchema _ = Nothing\n\nparseCommand : (schema : Schema) -> String -> String -> Maybe (Command schema)\nparseCommand schema \"add\" rest = case parseBySchema schema rest of\n Nothing => Nothing\n Just restok => Just (Add restok)\nparseCommand schema \"get\" val = case all isDigit (unpack val) of\n False => Nothing\n True => Just (Get (cast val))\nparseCommand schema \"quit\" \"\" = Just Quit\nparseCommand schema \"schema\" rest\n = case parseSchema (words rest) of\n Nothing => Nothing\n Just schemaok => Just (SetSchema schemaok)\nparseCommand _ _ _ = Nothing\n\nparse : (schema : Schema) -> (input : String) -> Maybe (Command schema)\nparse schema input = case span (/= ' ') input of\n (cmd, args) => parseCommand schema cmd (ltrim args)\n\ndisplay : SchemaType schema -> String\ndisplay {schema = SString} item = show item\ndisplay {schema = SInt} item = show item\ndisplay {schema = (y .+. z)} (iteml, itemr) = display iteml ++ \", \" ++\n display itemr\n\ngetEntry : (pos : Integer) -> (store : DataStore) ->\n Maybe (String, DataStore)\ngetEntry pos store\n = let store_items = items store in\n case integerToFin pos (size store) of\n Nothing => Just (\"Out of range\\n\", store)\n Just id => Just (display (index id (items store)) ++ \"\\n\", store)\n\nprocessInput : DataStore -> String -> Maybe (String, DataStore)\nprocessInput store input\n = case parse (schema store) input of\n Nothing => Just (\"Invalid command\\n\", store)\n Just (Add item) =>\n Just (\"ID \" ++ show (size store) ++ \"\\n\", addToStore store item)\n Just (SetSchema schema') =>\n case setSchema store schema' of\n Nothing => Just (\"Can't update schema when entries in store\\n\", store)\n Just store' => Just (\"OK\\n\", store')\n Just (Get pos) => getEntry pos store\n Just Quit => Nothing\n\nmain : IO ()\nmain = replWith (MkData (SString .+. SString .+. SInt) _ []) \"Command: \" processInput\n" }, { "path": "Chapter6/DataStoreHoles.idr", "content": "module Main\n\nimport Data.Vect\n\ninfixr 5 .+.\n\ndata Schema = SString | SInt | (.+.) Schema Schema\n\nSchemaType : Schema -> Type\nSchemaType SString = String\nSchemaType SInt = Int\nSchemaType (x .+. y) = (SchemaType x, SchemaType y)\n\nrecord DataStore where\n constructor MkData\n schema : Schema\n size : Nat\n items : Vect size (SchemaType schema)\n\naddToStore : (d : DataStore) -> SchemaType (schema d) -> DataStore\naddToStore (MkData schema size store) newitem = MkData schema _ (addToData store)\n where\n addToData : Vect oldsize (SchemaType schema) -> Vect (S oldsize) (SchemaType schema)\n addToData [] = [newitem]\n addToData (x :: xs) = x :: addToData xs\n\ndata Command : Schema -> Type where\n Add : SchemaType schema -> Command schema\n Get : Integer -> Command schema\n Quit : Command schema\n\nparseCommand : String -> String -> Maybe (Command schema)\nparseCommand \"add\" rest = Just (Add (?parseBySchema rest))\nparseCommand \"get\" val = case all isDigit (unpack val) of\n False => Nothing\n True => Just (Get (cast val))\nparseCommand \"quit\" \"\" = Just Quit\nparseCommand _ _ = Nothing\n\nparse : (schema : Schema) -> (input : String) -> Maybe (Command schema)\nparse schema input = case span (/= ' ') input of\n (cmd, args) => parseCommand cmd (ltrim args)\n\ngetEntry : (pos : Integer) -> (store : DataStore) ->\n Maybe (String, DataStore)\ngetEntry pos store\n = let store_items = items store in\n case integerToFin pos (size store) of\n Nothing => Just (\"Out of range\\n\", store)\n Just id => Just (?display (index id (items store)) ++ \"\\n\", store)\n\nprocessInput : DataStore -> String -> Maybe (String, DataStore)\nprocessInput store input\n = case parse (schema store) input of\n Nothing => Just (\"Invalid command\\n\", store)\n Just (Add item) =>\n Just (\"ID \" ++ show (size store) ++ \"\\n\", addToStore store item)\n Just (Get pos) => getEntry pos store\n Just Quit => Nothing\n\nmain : IO ()\nmain = replWith (MkData SString _ []) \"Command: \" processInput\n" }, { "path": "Chapter6/Exercises/ex_6_2_1.idr", "content": "import Data.Vect\n\n{- 1 -}\n\nMatrix : Nat -> Nat -> Type\nMatrix n m = Vect n (Vect m Double)\n\ntestMatrix : Matrix 2 3\ntestMatrix = [[0, 0, 0], [0, 0, 0]]\n" }, { "path": "Chapter6/Exercises/ex_6_2_2.idr", "content": "data Format = Number Format\n | Str Format\n | Lit String Format\n | Ch Format\n | Dbl Format\n | End\n\nPrintfType : Format -> Type\nPrintfType (Number fmt) = (i : Int) -> PrintfType fmt\nPrintfType (Str fmt) = (str : String) -> PrintfType fmt\nPrintfType (Lit str fmt) = PrintfType fmt\nPrintfType (Ch fmt) = (c : Char) -> PrintfType fmt\nPrintfType (Dbl fmt) = (d : Double) -> PrintfType fmt\nPrintfType End = String\n\nprintfFmt : (fmt : Format) -> (acc : String) -> PrintfType fmt\nprintfFmt (Number fmt) acc = \\i => printfFmt fmt (acc ++ show i)\nprintfFmt (Str fmt) acc = \\str => printfFmt fmt (acc ++ str)\nprintfFmt (Ch fmt) acc = \\c => printfFmt fmt (acc ++ show c)\nprintfFmt (Dbl fmt) acc = \\d => printfFmt fmt (acc ++ show d)\nprintfFmt (Lit lit fmt) acc = printfFmt fmt (acc ++ lit)\nprintfFmt End acc = acc\n\ntoFormat : (xs : List Char) -> Format\ntoFormat [] = End\ntoFormat ('%' :: 'd' :: chars) = Number (toFormat chars)\ntoFormat ('%' :: 's' :: chars) = Str (toFormat chars)\ntoFormat ('%' :: 'c' :: chars) = Ch (toFormat chars)\ntoFormat ('%' :: 'f' :: chars) = Dbl (toFormat chars)\ntoFormat ('%' :: chars) = Lit \"%\" (toFormat chars)\ntoFormat (c :: chars) = case toFormat chars of\n Lit lit chars' => Lit (strCons c lit) chars'\n fmt => Lit (strCons c \"\") fmt\nprintf : (fmt : String) -> PrintfType (toFormat (unpack fmt))\nprintf fmt = printfFmt _ \"\"\n" }, { "path": "Chapter6/Exercises/ex_6_2_3.idr", "content": "TupleVect : Nat -> Type -> Type\nTupleVect Z ty = ()\nTupleVect (S k) ty = (ty, TupleVect k ty)\n\ntest : TupleVect 4 Nat\ntest = (1,2,3,4,())\n" }, { "path": "Chapter6/Exercises/ex_6_3_1.idr", "content": "module Main\n\nimport Data.Vect\n\ninfixr 5 .+.\n\ndata Schema = SString | SInt | SChar | (.+.) Schema Schema\n\nSchemaType : Schema -> Type\nSchemaType SString = String\nSchemaType SInt = Int\nSchemaType SChar = Char\nSchemaType (x .+. y) = (SchemaType x, SchemaType y)\n\nrecord DataStore where\n constructor MkData\n schema : Schema\n size : Nat\n items : Vect size (SchemaType schema)\n\naddToStore : (store : DataStore) -> SchemaType (schema store) -> DataStore\naddToStore (MkData schema size store) newitem = MkData schema _ (addToData store)\n where\n addToData : Vect oldsize (SchemaType schema) -> Vect (S oldsize) (SchemaType schema)\n addToData [] = [newitem]\n addToData (x :: xs) = x :: addToData xs\n\nsetSchema : (store : DataStore) -> Schema -> Maybe DataStore\nsetSchema store schema = case size store of\n Z => Just (MkData schema _ [])\n S k => Nothing\n\ndata Command : Schema -> Type where\n SetSchema : Schema -> Command schema\n Add : SchemaType schema -> Command schema\n Get : Integer -> Command schema\n Quit : Command schema\n\n\nparsePrefix : (schema : Schema) -> String -> Maybe (SchemaType schema, String)\nparsePrefix SString input = getQuoted (unpack input)\n where\n getQuoted : List Char -> Maybe (String, String)\n getQuoted ('\"' :: xs)\n = case span (/= '\"') xs of\n (quoted, '\"' :: rest) => Just (pack quoted, ltrim (pack rest))\n _ => Nothing\n getQuoted _ = Nothing\n\nparsePrefix SInt input = case span isDigit input of\n (\"\", rest) => Nothing\n (num, rest) => Just (cast num, ltrim rest)\nparsePrefix SChar input = case unpack input of\n (c :: cs) => Just (c, ltrim (pack cs))\n [] => Nothing\nparsePrefix (schemal .+. schemar) input\n = case parsePrefix schemal input of\n Nothing => Nothing\n Just (l_val, input') =>\n case parsePrefix schemar input' of\n Nothing => Nothing\n Just (r_val, input'') => Just ((l_val, r_val), input'')\n\nparseBySchema : (schema : Schema) -> String -> Maybe (SchemaType schema)\nparseBySchema schema x = case parsePrefix schema x of\n Nothing => Nothing\n Just (res, \"\") => Just res\n Just _ => Nothing\n\nparseSchema : List String -> Maybe Schema\nparseSchema (\"String\" :: xs)\n = case xs of\n [] => Just SString\n _ => case parseSchema xs of\n Nothing => Nothing\n Just xs_sch => Just (SString .+. xs_sch)\nparseSchema (\"Int\" :: xs)\n = case xs of\n [] => Just SInt\n _ => case parseSchema xs of\n Nothing => Nothing\n Just xs_sch => Just (SInt .+. xs_sch)\nparseSchema (\"Char\" :: xs)\n = case xs of\n [] => Just SInt\n _ => case parseSchema xs of\n Nothing => Nothing\n Just xs_sch => Just (SChar .+. xs_sch)\nparseSchema _ = Nothing\n\nparseCommand : (schema : Schema) -> String -> String -> Maybe (Command schema)\nparseCommand schema \"add\" rest = case parseBySchema schema rest of\n Nothing => Nothing\n Just restok => Just (Add restok)\nparseCommand schema \"get\" val = case all isDigit (unpack val) of\n False => Nothing\n True => Just (Get (cast val))\nparseCommand schema \"quit\" \"\" = Just Quit\nparseCommand schema \"schema\" rest\n = case parseSchema (words rest) of\n Nothing => Nothing\n Just schemaok => Just (SetSchema schemaok)\nparseCommand _ _ _ = Nothing\n\nparse : (schema : Schema) -> (input : String) -> Maybe (Command schema)\nparse schema input = case span (/= ' ') input of\n (cmd, args) => parseCommand schema cmd (ltrim args)\n\ndisplay : SchemaType schema -> String\ndisplay {schema = SString} item = show item\ndisplay {schema = SInt} item = show item\ndisplay {schema = SChar} item = show item\ndisplay {schema = (y .+. z)} (iteml, itemr) = display iteml ++ \", \" ++\n display itemr\n\ngetEntry : (pos : Integer) -> (store : DataStore) ->\n Maybe (String, DataStore)\ngetEntry pos store\n = let store_items = items store in\n case integerToFin pos (size store) of\n Nothing => Just (\"Out of range\\n\", store)\n Just id => Just (display (index id (items store)) ++ \"\\n\", store)\n\nprocessInput : DataStore -> String -> Maybe (String, DataStore)\nprocessInput store input\n = case parse (schema store) input of\n Nothing => Just (\"Invalid command\\n\", store)\n Just (Add item) =>\n Just (\"ID \" ++ show (size store) ++ \"\\n\", addToStore store item)\n Just (SetSchema schema') =>\n case setSchema store schema' of\n Nothing => Just (\"Can't update schema when entries in store\\n\", store)\n Just store' => Just (\"OK\\n\", store')\n Just (Get pos) => getEntry pos store\n Just Quit => Nothing\n\nmain : IO ()\nmain = replWith (MkData (SString .+. SString .+. SInt) _ []) \"Command: \" processInput\n" }, { "path": "Chapter6/Exercises/ex_6_3_2.idr", "content": "module Main\n\nimport Data.Vect\n\ninfixr 5 .+.\n\ndata Schema = SString | SInt | SChar | (.+.) Schema Schema\n\nSchemaType : Schema -> Type\nSchemaType SString = String\nSchemaType SInt = Int\nSchemaType SChar = Char\nSchemaType (x .+. y) = (SchemaType x, SchemaType y)\n\nrecord DataStore where\n constructor MkData\n schema : Schema\n size : Nat\n items : Vect size (SchemaType schema)\n\naddToStore : (store : DataStore) -> SchemaType (schema store) -> DataStore\naddToStore (MkData schema size store) newitem = MkData schema _ (addToData store)\n where\n addToData : Vect oldsize (SchemaType schema) -> Vect (S oldsize) (SchemaType schema)\n addToData [] = [newitem]\n addToData (x :: xs) = x :: addToData xs\n\nsetSchema : (store : DataStore) -> Schema -> Maybe DataStore\nsetSchema store schema = case size store of\n Z => Just (MkData schema _ [])\n S k => Nothing\n\ndata Command : Schema -> Type where\n SetSchema : Schema -> Command schema\n Add : SchemaType schema -> Command schema\n Get : Maybe Integer -> Command schema\n Quit : Command schema\n\n\nparsePrefix : (schema : Schema) -> String -> Maybe (SchemaType schema, String)\nparsePrefix SString input = getQuoted (unpack input)\n where\n getQuoted : List Char -> Maybe (String, String)\n getQuoted ('\"' :: xs)\n = case span (/= '\"') xs of\n (quoted, '\"' :: rest) => Just (pack quoted, ltrim (pack rest))\n _ => Nothing\n getQuoted _ = Nothing\n\nparsePrefix SInt input = case span isDigit input of\n (\"\", rest) => Nothing\n (num, rest) => Just (cast num, ltrim rest)\nparsePrefix SChar input = case unpack input of\n (c :: cs) => Just (c, ltrim (pack cs))\n [] => Nothing\nparsePrefix (schemal .+. schemar) input\n = case parsePrefix schemal input of\n Nothing => Nothing\n Just (l_val, input') =>\n case parsePrefix schemar input' of\n Nothing => Nothing\n Just (r_val, input'') => Just ((l_val, r_val), input'')\n\nparseBySchema : (schema : Schema) -> String -> Maybe (SchemaType schema)\nparseBySchema schema x = case parsePrefix schema x of\n Nothing => Nothing\n Just (res, \"\") => Just res\n Just _ => Nothing\n\nparseSchema : List String -> Maybe Schema\nparseSchema (\"String\" :: xs)\n = case xs of\n [] => Just SString\n _ => case parseSchema xs of\n Nothing => Nothing\n Just xs_sch => Just (SString .+. xs_sch)\nparseSchema (\"Int\" :: xs)\n = case xs of\n [] => Just SInt\n _ => case parseSchema xs of\n Nothing => Nothing\n Just xs_sch => Just (SInt .+. xs_sch)\nparseSchema (\"Char\" :: xs)\n = case xs of\n [] => Just SInt\n _ => case parseSchema xs of\n Nothing => Nothing\n Just xs_sch => Just (SChar .+. xs_sch)\nparseSchema _ = Nothing\n\nparseCommand : (schema : Schema) -> String -> String -> Maybe (Command schema)\nparseCommand schema \"add\" rest = case parseBySchema schema rest of\n Nothing => Nothing\n Just restok => Just (Add restok)\nparseCommand schema \"get\" \"\" = Just (Get Nothing)\nparseCommand schema \"get\" val = case all isDigit (unpack val) of\n False => Nothing\n True => Just (Get (Just (cast val)))\nparseCommand schema \"quit\" \"\" = Just Quit\nparseCommand schema \"schema\" rest\n = case parseSchema (words rest) of\n Nothing => Nothing\n Just schemaok => Just (SetSchema schemaok)\nparseCommand _ _ _ = Nothing\n\nparse : (schema : Schema) -> (input : String) -> Maybe (Command schema)\nparse schema input = case span (/= ' ') input of\n (cmd, args) => parseCommand schema cmd (trim args)\n\ndisplay : SchemaType schema -> String\ndisplay {schema = SString} item = show item\ndisplay {schema = SInt} item = show item\ndisplay {schema = SChar} item = show item\ndisplay {schema = (y .+. z)} (iteml, itemr) = display iteml ++ \", \" ++\n display itemr\n\ngetEntry : (pos : Integer) -> (store : DataStore) ->\n Maybe (String, DataStore)\ngetEntry pos store\n = let store_items = items store in\n case integerToFin pos (size store) of\n Nothing => Just (\"Out of range\\n\", store)\n Just id => Just (display (index id (items store)) ++ \"\\n\", store)\n\nshowAll : Nat -> Vect size (SchemaType schema) -> String\nshowAll idx [] = \"\"\nshowAll idx (x :: xs) = show idx ++ \": \" ++ display x ++ \"\\n\" ++\n showAll (idx + 1) xs\n\nprocessInput : DataStore -> String -> Maybe (String, DataStore)\nprocessInput store input\n = case parse (schema store) input of\n Nothing => Just (\"Invalid command\\n\", store)\n Just (Add item) =>\n Just (\"ID \" ++ show (size store) ++ \"\\n\", addToStore store item)\n Just (SetSchema schema') =>\n case setSchema store schema' of\n Nothing => Just (\"Can't update schema when entries in store\\n\", store)\n Just store' => Just (\"OK\\n\", store')\n Just (Get (Just pos)) => getEntry pos store\n Just (Get Nothing) => Just (showAll 0 (items store) ++ \"\\n\", store)\n Just Quit => Nothing\n\nmain : IO ()\nmain = replWith (MkData (SString .+. SString .+. SInt) _ []) \"Command: \" processInput\n" }, { "path": "Chapter6/Exercises/ex_6_3_3.idr", "content": "module Main\n\nimport Data.Vect\n\ninfixr 5 .+.\n\ndata Schema = SString | SInt | SChar | (.+.) Schema Schema\n\nSchemaType : Schema -> Type\nSchemaType SString = String\nSchemaType SInt = Int\nSchemaType SChar = Char\nSchemaType (x .+. y) = (SchemaType x, SchemaType y)\n\nrecord DataStore where\n constructor MkData\n schema : Schema\n size : Nat\n items : Vect size (SchemaType schema)\n\naddToStore : (store : DataStore) -> SchemaType (schema store) -> DataStore\naddToStore (MkData schema size store) newitem = MkData schema _ (addToData store)\n where\n addToData : Vect oldsize (SchemaType schema) -> Vect (S oldsize) (SchemaType schema)\n addToData [] = [newitem]\n addToData (x :: xs) = x :: addToData xs\n\nsetSchema : (store : DataStore) -> Schema -> Maybe DataStore\nsetSchema store schema = case size store of\n Z => Just (MkData schema _ [])\n S k => Nothing\n\ndata Command : Schema -> Type where\n SetSchema : Schema -> Command schema\n Add : SchemaType schema -> Command schema\n Get : Maybe Integer -> Command schema\n Quit : Command schema\n\n\nparsePrefix : (schema : Schema) -> String -> Maybe (SchemaType schema, String)\nparsePrefix SString input = getQuoted (unpack input)\n where\n getQuoted : List Char -> Maybe (String, String)\n getQuoted ('\"' :: xs)\n = case span (/= '\"') xs of\n (quoted, '\"' :: rest) => Just (pack quoted, ltrim (pack rest))\n _ => Nothing\n getQuoted _ = Nothing\n\nparsePrefix SInt input = case span isDigit input of\n (\"\", rest) => Nothing\n (num, rest) => Just (cast num, ltrim rest)\nparsePrefix SChar input = case unpack input of\n (c :: cs) => Just (c, ltrim (pack cs))\n [] => Nothing\nparsePrefix (schemal .+. schemar) input\n = do (l_val, input') <- parsePrefix schemal input\n (r_val, input'') <- parsePrefix schemar input'\n Just ((l_val, r_val), input'')\n\nparseBySchema : (schema : Schema) -> String -> Maybe (SchemaType schema)\nparseBySchema schema x = case parsePrefix schema x of\n Nothing => Nothing\n Just (res, \"\") => Just res\n Just _ => Nothing\n\nparseSchema : List String -> Maybe Schema\nparseSchema (\"String\" :: xs)\n = case xs of\n [] => Just SString\n _ => do xs_sch <- parseSchema xs\n Just (SString .+. xs_sch)\nparseSchema (\"Int\" :: xs)\n = case xs of\n [] => Just SInt\n _ => do xs_sch <- parseSchema xs\n Just (SInt .+. xs_sch)\nparseSchema (\"Char\" :: xs)\n = case xs of\n [] => Just SInt\n _ => do xs_sch <- parseSchema xs\n Just (SChar .+. xs_sch)\nparseSchema _ = Nothing\n\nparseCommand : (schema : Schema) -> String -> String -> Maybe (Command schema)\nparseCommand schema \"add\" rest = do restok <- parseBySchema schema rest\n Just (Add restok)\nparseCommand schema \"get\" \"\" = Just (Get Nothing)\nparseCommand schema \"get\" val = case all isDigit (unpack val) of\n False => Nothing\n True => Just (Get (Just (cast val)))\nparseCommand schema \"quit\" \"\" = Just Quit\nparseCommand schema \"schema\" rest\n = case parseSchema (words rest) of\n Nothing => Nothing\n Just schemaok => Just (SetSchema schemaok)\nparseCommand _ _ _ = Nothing\n\nparse : (schema : Schema) -> (input : String) -> Maybe (Command schema)\nparse schema input = case span (/= ' ') input of\n (cmd, args) => parseCommand schema cmd (trim args)\n\ndisplay : SchemaType schema -> String\ndisplay {schema = SString} item = show item\ndisplay {schema = SInt} item = show item\ndisplay {schema = SChar} item = show item\ndisplay {schema = (y .+. z)} (iteml, itemr) = display iteml ++ \", \" ++\n display itemr\n\ngetEntry : (pos : Integer) -> (store : DataStore) ->\n Maybe (String, DataStore)\ngetEntry pos store\n = let store_items = items store in\n case integerToFin pos (size store) of\n Nothing => Just (\"Out of range\\n\", store)\n Just id => Just (display (index id (items store)) ++ \"\\n\", store)\n\nshowAll : Nat -> Vect size (SchemaType schema) -> String\nshowAll idx [] = \"\"\nshowAll idx (x :: xs) = show idx ++ \": \" ++ display x ++ \"\\n\" ++\n showAll (idx + 1) xs\n\nprocessInput : DataStore -> String -> Maybe (String, DataStore)\nprocessInput store input\n = case parse (schema store) input of\n Nothing => Just (\"Invalid command\\n\", store)\n Just (Add item) =>\n Just (\"ID \" ++ show (size store) ++ \"\\n\", addToStore store item)\n Just (SetSchema schema') =>\n case setSchema store schema' of\n Nothing => Just (\"Can't update schema when entries in store\\n\", store)\n Just store' => Just (\"OK\\n\", store')\n Just (Get (Just pos)) => getEntry pos store\n Just (Get Nothing) => Just (showAll 0 (items store) ++ \"\\n\", store)\n Just Quit => Nothing\n\nmain : IO ()\nmain = replWith (MkData (SString .+. SString .+. SInt) _ []) \"Command: \" processInput\n" }, { "path": "Chapter6/Maybe.idr", "content": "maybeAdd : Maybe Int -> Maybe Int -> Maybe Int\nmaybeAdd x y = case x of\n Nothing => Nothing\n Just x_val => case y of\n Nothing => Nothing\n Just y_val => Just (x_val + y_val)\n\nmaybeAdd' : Maybe Int -> Maybe Int -> Maybe Int\nmaybeAdd' x y = x >>= \\x_val =>\n y >>= \\y_val =>\n Just (x_val + y_val)\n\nmaybeAdd'' : Maybe Int -> Maybe Int -> Maybe Int\nmaybeAdd'' x y = do x_val <- x\n y_val <- y\n Just (x_val + y_val)\n" }, { "path": "Chapter6/Printf.idr", "content": "data Format = Number Format\n | Str Format\n | Lit String Format\n | End\n\nPrintfType : Format -> Type\nPrintfType (Number fmt) = (i : Int) -> PrintfType fmt\nPrintfType (Str fmt) = (str : String) -> PrintfType fmt\nPrintfType (Lit str fmt) = PrintfType fmt\nPrintfType End = String\n\nprintfFmt : (fmt : Format) -> (acc : String) -> PrintfType fmt\nprintfFmt (Number fmt) acc = \\i => printfFmt fmt (acc ++ show i)\nprintfFmt (Str fmt) acc = \\str => printfFmt fmt (acc ++ str)\nprintfFmt (Lit lit fmt) acc = printfFmt fmt (acc ++ lit)\nprintfFmt End acc = acc\n\ntoFormat : (xs : List Char) -> Format\ntoFormat [] = End\ntoFormat ('%' :: 'd' :: chars) = Number (toFormat chars)\ntoFormat ('%' :: 's' :: chars) = Str (toFormat chars)\ntoFormat ('%' :: chars) = Lit \"%\" (toFormat chars)\ntoFormat (c :: chars) = case toFormat chars of\n Lit lit chars' => Lit (strCons c lit) chars'\n fmt => Lit (strCons c \"\") fmt\nprintf : (fmt : String) -> PrintfType (toFormat (unpack fmt))\nprintf fmt = printfFmt _ \"\"\n" }, { "path": "Chapter6/TypeFuns.idr", "content": "import Data.Vect\n\nStringOrInt : Bool -> Type\nStringOrInt False = String\nStringOrInt True = Int\n\ngetStringOrInt : (isInt : Bool) -> StringOrInt isInt\ngetStringOrInt False = \"Ninety four\"\ngetStringOrInt True = 94\n\nvalToString : (isInt : Bool) -> StringOrInt isInt -> String\nvalToString False y = trim y\nvalToString True y = cast y\n\nvalToString' : (isInt : Bool) -> (case isInt of\n False => String\n True => Int) -> String\nvalToString' False y = trim y\nvalToString' True y = cast y\n" }, { "path": "Chapter6/TypeSynonyms.idr", "content": "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 = (Double, Double)\n\ntri' : Vect 3 Position\ntri' = [(0.0, 0.0), (3.0, 0.0), (0.0, 4.0)]\n\nPolygon : Nat -> Type\nPolygon n = Vect n Position\n\ntri'' : Polygon 3\ntri'' = [(0.0, 0.0), (3.0, 0.0), (0.0, 4.0)]\n" }, { "path": "Chapter7/Album.idr", "content": "record Album where\n constructor MkAlbum\n artist : String\n title : String\n year : Integer\n\nhelp : Album\nhelp = MkAlbum \"The Beatles\" \"Help\" 1965\n\nrubbersoul : Album\nrubbersoul = MkAlbum \"The Beatles\" \"Rubber Soul\" 1965\n\nclouds : Album\nclouds = MkAlbum \"Joni Mitchell\" \"Clouds\" 1969\n\nhunkydory : Album\nhunkydory = MkAlbum \"David Bowie\" \"Hunky Dory\" 1971\n\nheroes : Album\nheroes = MkAlbum \"David Bowie\" \"Heroes\" 1977\n\ncollection : List Album\ncollection = [help, rubbersoul, clouds, hunkydory, heroes]\n\nEq Album where\n (==) (MkAlbum artist title year) (MkAlbum artist' title' year')\n = artist == artist' && title == title' && year == year'\n\nOrd Album where\n compare (MkAlbum artist title year) (MkAlbum artist' title' year')\n = case compare artist artist' of\n EQ => case compare year year' of\n EQ => compare title title'\n diff_year => diff_year\n diff_artist => diff_artist\n\nShow Album where\n show (MkAlbum artist title year)\n = title ++ \" by \" ++ artist ++ \" (released \" ++ show year ++ \")\"\n" }, { "path": "Chapter7/Eq.idr", "content": "occurrences : Eq ty => (item : ty) -> (values : List ty) -> Nat\noccurrences item [] = 0\noccurrences item (value :: values) = case x == item of\n False => occurrences item values\n True => 1 + occurrences item values\n\ndata Matter = Solid | Liquid | Gas\n\nEq Matter where\n (==) Solid Solid = True\n (==) Liquid Liquid = True\n (==) Gas Gas = True\n (==) _ _ = False\n" }, { "path": "Chapter7/Exercises/ex_7_1.idr", "content": "data Shape = Triangle Double Double\n | Rectangle Double Double\n | Circle Double\n\narea : Shape -> Double\narea (Triangle base height) = 0.5 * base * height\narea (Rectangle length height) = length * height\narea (Circle radius) = pi * radius * radius\n\n{- 1 -}\n\nEq Shape where\n (==) (Triangle base height) (Triangle base' height')\n = base == base' && height == height'\n (==) (Rectangle length height) (Rectangle length' height')\n = length == length' && height == height'\n (==) (Circle radius) (Circle radius') = radius == radius'\n (==) _ _ = False\n\n{- 2 -}\n\nOrd Shape where\n compare x y = compare (area x) (area y)\n\ntestShapes : List Shape\ntestShapes = [Circle 3, Triangle 3 9, Rectangle 2 6, Circle 4, \n Rectangle 2 7]\n" }, { "path": "Chapter7/Exercises/ex_7_2.idr", "content": "data Expr num = Val num\n | Add (Expr num) (Expr num)\n | Sub (Expr num) (Expr num)\n | Mul (Expr num) (Expr num)\n | Div (Expr num) (Expr num)\n | Abs (Expr num)\n\neval : (Neg num, Integral num) => Expr num -> num\neval (Val x) = x\neval (Add x y) = eval x + eval y\neval (Sub x y) = eval x - eval y\neval (Mul x y) = eval x * eval y\neval (Div x y) = eval x `div` eval y\neval (Abs x) = abs (eval x)\n\nNum ty => Num (Expr ty) where\n (+) = Add\n (*) = Mul\n fromInteger = Val . fromInteger\n\nNeg ty => Neg (Expr ty) where\n negate x = 0 - x\n (-) = Sub\n abs = Abs\n\n{- 1 -}\n\nshowOp : Show a => String -> a -> a -> String\nshowOp op x y = \"(\" ++ show x ++ op ++ show y ++ \")\"\n\nShow ty => Show (Expr ty) where\n show (Val x) = show x\n show (Add x y) = showOp \" + \" x y\n show (Sub x y) = showOp \" - \" x y\n show (Mul x y) = showOp \" * \" x y\n show (Div x y) = showOp \" / \" x y\n show (Abs x) = \"abs \" ++ show x\n\n{- 2 -}\n\n(Neg a, Integral a, Eq a) => Eq (Expr a) where\n (==) x y = eval x == eval y\n\n{- 3 -}\n\n(Neg num, Integral num) => Cast (Expr num) num where\n cast orig = eval orig\n" }, { "path": "Chapter7/Exercises/ex_7_3_1.idr", "content": "data Expr num = Val num\n | Add (Expr num) (Expr num)\n | Sub (Expr num) (Expr num)\n | Mul (Expr num) (Expr num)\n | Div (Expr num) (Expr num)\n | Abs (Expr num)\n\neval : (Neg num, Integral num) => Expr num -> num\neval (Val x) = x\neval (Add x y) = eval x + eval y\neval (Sub x y) = eval x - eval y\neval (Mul x y) = eval x * eval y\neval (Div x y) = eval x `div` eval y\neval (Abs x) = abs (eval x)\n\nNum ty => Num (Expr ty) where\n (+) = Add\n (*) = Mul\n fromInteger = Val . fromInteger\n\nNeg ty => Neg (Expr ty) where\n negate x = 0 - x\n (-) = Sub\n abs = Abs\n\nFunctor Expr where\n map f (Val x) = Val (f x)\n map f (Add x y) = Add (map f x) (map f y)\n map f (Sub x y) = Sub (map f x) (map f y)\n map f (Mul x y) = Mul (map f x) (map f y)\n map f (Div x y) = Div (map f x) (map f y)\n map f (Abs x) = Abs (map f x)\n" }, { "path": "Chapter7/Exercises/ex_7_3_2.idr", "content": "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\nEq a => Eq (Vect n a) where\n (==) [] [] = True\n (==) (x :: xs) (y :: ys) = x == y && xs == ys\n\nFoldable (Vect n) where\n foldr f acc [] = acc\n foldr f acc (x :: xs) = f x (foldr f acc xs)\n" }, { "path": "Chapter7/Expr.idr", "content": "data Expr num = Val num\n | Add (Expr num) (Expr num)\n | Sub (Expr num) (Expr num)\n | Mul (Expr num) (Expr num)\n | Div (Expr num) (Expr num)\n | Abs (Expr num)\n\neval : (Neg num, Integral num) => Expr num -> num\neval (Val x) = x\neval (Add x y) = eval x + eval y\neval (Sub x y) = eval x - eval y\neval (Mul x y) = eval x * eval y\neval (Div x y) = eval x `div` eval y\neval (Abs x) = abs (eval x)\n\nNum ty => Num (Expr ty) where\n (+) = Add\n (*) = Mul\n fromInteger = Val . fromInteger\n \nNeg ty => Neg (Expr ty) where\n negate x = 0 - x\n (-) = Sub\n abs = Abs\n" }, { "path": "Chapter7/Fold.idr", "content": "totalLen : List String -> Nat\ntotalLen xs = foldr (\\str, len => length str + len) 0 xs\n" }, { "path": "Chapter7/Tree.idr", "content": "data Tree elem = Empty\n | Node (Tree elem) elem (Tree elem)\n\nEq elem => Eq (Tree elem) where\n (==) Empty Empty = True\n (==) (Node left e right) (Node left' e' right')\n = left == left' && e == e' && right == right'\n (==) _ _ = False\n\nFunctor Tree where\n map f Empty = Empty\n map f (Node left e right)\n = Node (map f left)\n (f e)\n (map f right)\n\nFoldable Tree where\n foldr f acc Empty = acc\n foldr f acc (Node left e right) = let leftfold = foldr f acc left\n rightfold = foldr f leftfold right in\n f e rightfold\n" }, { "path": "Chapter8/AppendVec.idr", "content": "import Data.Vect\n\nappend_nil : Vect m elem -> Vect (plus m 0) elem\nappend_nil {m} xs = rewrite plusZeroRightNeutral m in xs\n\nappend_xs : Vect (S (m + k)) elem -> Vect (plus m (S k)) elem\nappend_xs {m} {k} xs = rewrite sym (plusSuccRightSucc m k) in xs\n\nappend : Vect n elem -> Vect m elem -> Vect (m + n) elem\nappend [] ys = append_nil ys\nappend (x :: xs) ys = append_xs (x :: append xs ys)\n" }, { "path": "Chapter8/CheckEqDec.idr", "content": "\nzeroNotSuc : (0 = S k) -> Void\nzeroNotSuc Refl impossible\n\nsucNotZero : (S k = 0) -> Void\nsucNotZero Refl impossible\n\nnoRec : (contra : (k = j) -> Void) -> (S k = S j) -> Void\nnoRec contra Refl = contra Refl\n\ncheckEqNat : (num1 : Nat) -> (num2 : Nat) -> Dec (num1 = num2)\ncheckEqNat Z Z = Yes Refl\ncheckEqNat Z (S k) = No zeroNotSuc\ncheckEqNat (S k) Z = No sucNotZero\ncheckEqNat (S k) (S j) = case checkEqNat k j of\n Yes prf => Yes (cong prf)\n No contra => No (noRec contra)\n" }, { "path": "Chapter8/CheckEqMaybe.idr", "content": "checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Maybe (num1 = num2)\ncheckEqNat Z Z = Just Refl\ncheckEqNat Z (S k) = Nothing\ncheckEqNat (S k) Z = Nothing\ncheckEqNat (S k) (S j) = case checkEqNat k j of\n Nothing => Nothing\n Just prf => Just (cong prf)\n" }, { "path": "Chapter8/EqNat.idr", "content": "data EqNat : Nat -> Nat -> Type where\n Same : (x : Nat) -> EqNat x x\n\nsameS : (k : Nat) -> (j : Nat) -> (eq : EqNat k j) -> EqNat (S k) (S j)\nsameS k k (Same k) = Same (S k)\n\ncheckEqNat : (num1 : Nat) -> (num2 : Nat) -> Maybe (EqNat num1 num2)\ncheckEqNat Z Z = Just (Same Z)\ncheckEqNat Z (S k) = Nothing\ncheckEqNat (S k) Z = Nothing\ncheckEqNat (S k) (S j) = case checkEqNat k j of\n Nothing => Nothing\n Just eq => Just (sameS _ _ eq)\n\n\n" }, { "path": "Chapter8/ExactLength.idr", "content": "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, zs\n\ndata EqNat : Nat -> Nat -> Type where\n Same : (x : Nat) -> EqNat x x\n\nsameS : (k : Nat) -> (j : Nat) -> (eq : EqNat k j) -> EqNat (S k) (S j)\nsameS k k (Same k) = Same (S k)\n\ncheckEqNat : (num1 : Nat) -> (num2 : Nat) -> Maybe (EqNat num1 num2)\ncheckEqNat Z Z = Just (Same Z)\ncheckEqNat Z (S k) = Nothing\ncheckEqNat (S k) Z = Nothing\ncheckEqNat (S k) (S j) = case checkEqNat k j of\n Nothing => Nothing\n Just eq => Just (sameS _ _ eq)\n\nexactLength : (len : Nat) -> (input : Vect m a) -> Maybe (Vect len a)\nexactLength {m} len input = case checkEqNat m len of\n Nothing => Nothing\n Just (Same len) => Just input\n" }, { "path": "Chapter8/ExactLengthDec.idr", "content": "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, zs\n\nexactLength : (len : Nat) -> (input : Vect m a) -> Maybe (Vect len a)\nexactLength {m} len input = case decEq m len of\n Yes Refl => Just input\n No contra => Nothing\n" }, { "path": "Chapter8/Exercises/ex_8_1.idr", "content": "{- 1 -}\n\nsame_cons : {xs : List a} -> {ys : List a} ->\n xs = ys -> x :: xs = x :: ys\nsame_cons Refl = Refl\n\n{- 2 -}\n\nsame_lists : {xs : List a} -> {ys : List a} ->\n x = y -> xs = ys -> x :: xs = y :: ys\nsame_lists Refl Refl = Refl\n\n{- 3 -}\n\ndata ThreeEq : a -> b -> c -> Type where\n AllSame : ThreeEq x x x\n\n{- 4 -}\n\nallSameS : (x, y, z : Nat) -> ThreeEq x y z -> ThreeEq (S x) (S y) (S z)\nallSameS x x x AllSame = AllSame\n\n-- If you add a successor to three equal Nats, the results are all equal\n" }, { "path": "Chapter8/Exercises/ex_8_2.idr", "content": "import Data.Vect\n\n{- 1 -}\n\nmyPlusCommutes : (n : Nat) -> (m : Nat) -> n + m = m + n\nmyPlusCommutes Z m = rewrite plusZeroRightNeutral m in Refl\nmyPlusCommutes (S k) m = rewrite myPlusCommutes k m in\n rewrite plusSuccRightSucc m k in Refl\n\n{- 2 -}\n\nreverseProof_nil : Vect n a -> Vect (plus n 0) a\nreverseProof_nil {n} xs = rewrite plusZeroRightNeutral n in xs\n\nreverseProof_xs : Vect (S n + k) a -> Vect (plus n (S k)) a\nreverseProof_xs {n} {k} xs = rewrite sym (plusSuccRightSucc n k) in xs\n\nmyReverse : Vect n a -> Vect n a\nmyReverse xs = reverse' [] xs\n where reverse' : Vect n a -> Vect m a -> Vect (n+m) a\n reverse' acc [] = reverseProof_nil acc\n reverse' acc (x :: xs)\n = reverseProof_xs (reverse' (x::acc) xs)\n" }, { "path": "Chapter8/Exercises/ex_8_3.idr", "content": "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, zs\n\n{- 1 -}\n\nheadUnequal : DecEq a => {xs : Vect n a} -> {ys : Vect n a} ->\n (contra : (x = y) -> Void) -> (x :: xs) = (y :: ys) -> Void\nheadUnequal contra Refl = contra Refl\n\ntailUnequal : DecEq a => {xs : Vect n a} -> {ys : Vect n a} ->\n (contra : (xs = ys) -> Void) -> (x :: xs) = (y :: ys) -> Void\ntailUnequal contra Refl = contra Refl\n\n{- 2 -}\n\nDecEq a => DecEq (Vect n a) where\n decEq [] [] = Yes Refl\n decEq (x :: xs) (y :: ys) = case decEq x y of\n No contra => No (headUnequal contra)\n Yes Refl => case decEq xs ys of\n Yes Refl => Yes Refl\n No contra => No (tailUnequal contra)\n" }, { "path": "Chapter8/ReverseVec.idr", "content": "import Data.Vect\n\n\nmyReverse1 : Vect n a -> Vect n a\nmyReverse1 [] = []\nmyReverse1 {n = S k} (x :: xs)\n = let result = myReverse1 xs ++ [x] in\n rewrite plusCommutative 1 k in result\n\nmyReverse : Vect n a -> Vect n a\nmyReverse [] = []\nmyReverse (x :: xs) = reverseProof (myReverse xs ++ [x])\n where\n reverseProof : Vect (k + 1) a -> Vect (S k) a\n reverseProof {k} result = rewrite plusCommutative 1 k in result\n" }, { "path": "Chapter8/TCVects.idr", "content": "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", "content": "twoPlusTwoNotFive : 2 + 2 = 5 -> Void\ntwoPlusTwoNotFive Refl impossible\n\nvalueNotSuc : (x : Nat) -> x = S x -> Void\nvalueNotSuc _ Refl impossible\n\nloop : Void\nloop = loop\n\nnohead : Void\nnohead = getHead []\n where\n getHead : List Void -> Void\n getHead (x :: xs) = x\n" }, { "path": "Chapter9/Elem.idr", "content": "import Data.Vect\n\noneInVector : Elem 1 [1,2,3]\noneInVector = Here\n\nmaryInVector : Elem \"Mary\" [\"Peter\", \"Paul\", \"Mary\"]\nmaryInVector = There (There Here)\n\nfourNotInVector : Elem 4 [1,2,3] -> Void\nfourNotInVector (There (There (There Here))) impossible\nfourNotInVector (There (There (There (There _)))) impossible\n\npeteNotInVector : Elem \"Pete\" [\"John\", \"Paul\", \"George\", \"Ringo\"] -> Void\npeteNotInVector (There (There (There (There Here)))) impossible\npeteNotInVector (There (There (There (There (There _))))) impossible\n\n" }, { "path": "Chapter9/ElemBool.idr", "content": "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, zs\n\nelem : Eq a => (value : a) -> (xs : Vect n a) -> Bool\nelem value [] = False\nelem value (x :: xs) = case value == x of\n False => elem value xs\n True => True\n" }, { "path": "Chapter9/ElemType.idr", "content": "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, zs\n\ndata Elem : a -> Vect k a -> Type where\n Here : Elem x (x :: xs)\n There : (later : Elem x xs) -> Elem x (y :: xs)\n\nnot_in_nil : Elem value [] -> Void\nnot_in_nil Here impossible\nnot_in_nil (There _) impossible\n\nnot_in_tail : (notThere : Elem value xs -> Void) -> (notHere : (value = x) -> Void) -> Elem value (x :: xs) -> Void\nnot_in_tail notThere notHere Here = notHere Refl\nnot_in_tail notThere notHere (There later) = notThere later\n\nisElem : DecEq a => (value : a) -> (xs : Vect n a) -> Dec (Elem value xs)\nisElem value [] = No not_in_nil\nisElem value (x :: xs) = case decEq value x of\n Yes Refl => Yes Here\n No notHere => case isElem value xs of\n Yes prf => Yes (There prf)\n No notThere => No (not_in_tail notThere notHere)\n" }, { "path": "Chapter9/Exercises/ex_9_1.idr", "content": "{- 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{- 2 -}\n\ndata Last : List a -> a -> Type where\n LastOne : Last [value] value\n LastCons : (prf : Last xs value) -> Last (x :: xs) value\n\nlastNotNil : (value : a) -> Last [] x -> Void\nlastNotNil _ LastOne impossible\nlastNotNil _ (LastCons _) impossible\n\nlastNotCons : (contra : Last (x :: xs) value -> Void) ->\n Last (y :: (x :: xs)) value -> Void\nlastNotCons contra (LastCons prf) = contra prf\n\nlastNotSingleton : (contra : (y = value) -> Void) -> Last [y] value -> Void\nlastNotSingleton contra LastOne = contra Refl\nlastNotSingleton _ (LastCons LastOne) impossible\nlastNotSingleton _ (LastCons (LastCons _)) impossible\n\nisLast : DecEq a => (xs : List a) -> (value : a) -> Dec (Last xs value)\nisLast [] value = No (lastNotNil value)\nisLast (y :: []) value = case decEq y value of\n (Yes Refl) => Yes LastOne\n (No contra) => No (lastNotSingleton contra)\nisLast (y :: (x :: xs)) value = case isLast (x :: xs) value of\n (Yes prf) => Yes (LastCons prf)\n (No contra) => No (lastNotCons contra)\n" }, { "path": "Chapter9/Hangman.idr", "content": "import Data.Vect\n\ndata WordState : (guesses : Nat) -> (letters : Nat) -> Type where\n MkWordState : (word : String)\n -> (missing : Vect letters Char)\n -> WordState guesses_remaining letters\n\ndata Finished : Type where\n Lost : (game : WordState 0 (S letters)) -> Finished\n Won : (game : WordState (S guesses) 0) -> Finished\n\ntotal\nremoveElem : (value : a) -> (xs : Vect (S n) a) ->\n {auto prf : Elem value xs} ->\n Vect n a\nremoveElem value (value :: ys) {prf = Here} = ys\nremoveElem {n = Z} value (y :: []) {prf = There later} = absurd later\nremoveElem {n = (S k)} value (y :: ys) {prf = There later}\n = y :: removeElem value ys\n\nprocessGuess : (letter : Char) -> WordState (S guesses) (S letters) ->\n Either (WordState guesses (S letters))\n (WordState (S guesses) letters)\nprocessGuess letter (MkWordState word missing)\n = case isElem letter missing of\n Yes prf => Right (MkWordState word (removeElem letter missing))\n No contra => Left (MkWordState word missing)\n\ndata ValidInput : List Char -> Type where\n Letter : (c : Char) -> ValidInput [c]\n\nisValidNil : ValidInput [] -> Void\nisValidNil (Letter _) impossible\n\nisValidTwo : ValidInput (x :: (y :: xs)) -> Void\nisValidTwo (Letter _) impossible\n\nisValidInput : (cs : List Char) -> Dec (ValidInput cs)\nisValidInput [] = No isValidNil\nisValidInput (x :: []) = Yes (Letter x)\nisValidInput (x :: (y :: xs)) = No isValidTwo\n\nisValidString : (s : String) -> Dec (ValidInput (unpack s))\nisValidString s = isValidInput (unpack s)\n\nreadGuess : IO (x ** ValidInput x)\nreadGuess = do putStr \"Guess: \"\n x <- getLine\n case isValidString (toUpper x) of\n Yes prf => pure (_ ** prf)\n No contra => do putStrLn \"Invalid guess\"\n readGuess\n\ngame : WordState (S guesses) (S letters) -> IO Finished\ngame {guesses} {letters} st\n = do (_ ** Letter letter) <- readGuess\n case processGuess letter st of\n Left l => do putStrLn (\"Wrong! \" ++ show guesses ++\n \" guesses remaining\")\n case guesses of\n Z => pure (Lost l)\n S k => game l\n Right r => do putStrLn \"Right!\"\n case letters of\n Z => pure (Won r)\n S k => game r\n\nmain : IO ()\nmain = do result <- game {guesses=2} (MkWordState \"Test\" ['T', 'E', 'S'])\n case result of\n Lost (MkWordState word missing) =>\n putStrLn (\"You lose. The word was \" ++ word)\n Won game =>\n putStrLn \"You win!\"\n" }, { "path": "Chapter9/RemoveElem.idr", "content": "import Data.Vect\n\nremoveElem_v1 : DecEq a => (value : a) -> (xs : Vect (S n) a) -> Vect n a\nremoveElem_v1 value (x :: xs) = case decEq value x of\n Yes prf => xs\n No contra => ?removeElem_v1_rhs -- x :: removeElem_v1 value xs\n\nUninhabited (2 + 2 = 5) where\n uninhabited Refl impossible\n\n{-}\nremoveElem : (value : a) -> (xs : Vect (S n) a) ->\n Elem value xs ->\n Vect n a\nremoveElem value (value :: ys) Here = ys\nremoveElem {n = Z} value (y :: []) (There later) = absurd later\nremoveElem {n = (S k)} value (y :: ys) (There later)\n = y :: removeElem value ys later\n\nremoveElem_auto : (value : a) -> (xs : Vect (S n) a) ->\n {auto prf : Elem value xs} -> Vect n a\nremoveElem_auto value xs {prf} = removeElem value xs prf\n-}\n\nremoveElem : (value : a) -> (xs : Vect (S n) a) ->\n {auto prf : Elem value xs} ->\n Vect n a\nremoveElem value (value :: ys) {prf = Here} = ys\nremoveElem {n = Z} value (y :: []) {prf = There later} = absurd later\nremoveElem {n = (S k)} value (y :: ys) {prf = There later}\n = y :: removeElem value ys\n\nmy_elem : Eq a => (value : a) -> (xs : Vect n a) -> Bool\nmy_elem value [] = False\nmy_elem value (x :: xs) = case value == x of\n False => my_elem value xs\n True => True\n\nnot_in_nil : Elem value [] -> Void\nnot_in_nil Here impossible\nnot_in_nil (There _) impossible\n\nnot_in_tail : (contra1 : Elem value xs -> Void) -> (contra : (value = x) -> Void) -> Elem value (x :: xs) -> Void\nnot_in_tail contra1 contra Here = contra Refl\nnot_in_tail contra1 contra (There later) = contra1 later\n\nmy_decElem : DecEq a => (value : a) -> (xs : Vect n a) -> Dec (Elem value xs)\nmy_decElem value [] = No not_in_nil\nmy_decElem value (x :: xs)\n = case decEq value x of\n (Yes Refl) => Yes Here\n (No contra) => case my_decElem value xs of\n (Yes prf) => Yes (There prf)\n (No contra1) => No (not_in_tail contra1 contra)\n" }, { "path": "LICENSE", "content": "The MIT License (MIT)\n\nCopyright (c) 2017 Manning Publications Co.\n\nPermission is hereby granted, free of charge, to any person obtaining a copy\nof this software and associated documentation files (the \"Software\"), to deal\nin the Software without restriction, including without limitation the rights\nto use, copy, modify, merge, publish, distribute, sublicense, and/or sell\ncopies of the Software, and to permit persons to whom the Software is\nfurnished to do so, subject to the following conditions:\n\nThe above copyright notice and this permission notice shall be included in all\ncopies or substantial portions of the Software.\n\nTHE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR\nIMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,\nFITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE\nAUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER\nLIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,\nOUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE\nSOFTWARE.\n" }, { "path": "README.md", "content": "# Type Driven Development with Idris\n\nSample code and exercise solutions from \"Type Driven Development with Idris\",\navailable from https://www.manning.com/books/type-driven-development-with-idris\n" } ]